code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Marius Bakke <marius@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 ganeti)
  #:use-module (gnu packages virtualization)
  #:use-module (gnu services)
  #:use-module (gnu services mcron)
  #:use-module (gnu services shepherd)
  #:use-module (guix gexp)
  #:use-module (guix records)

  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)

  #:export (ganeti-noded-configuration
            ganeti-noded-configuration?
            ganeti-noded-configuration-ganeti
            ganeti-noded-configuration-port
            ganeti-noded-configuration-address
            ganeti-noded-configuration-interface
            ganeti-noded-configuration-max-clients
            ganeti-noded-configuration-ssl?
            ganeti-noded-configuration-ssl-key
            ganeti-noded-configuration-ssl-cert
            ganeti-noded-configuration-debug?
            ganeti-noded-service-type

            ganeti-confd-configuration
            ganeti-confd-configuration?
            ganeti-confd-configuration-ganeti
            ganeti-confd-configuration-port
            ganeti-confd-configuration-address
            ganeti-confd-configuration-debug
            ganeti-confd-service-type

            ganeti-wconfd-configuration
            ganeti-wconfd-configuration?
            ganeti-wconfd-configuration-ganeti
            ganeti-wconfd-configuration-no-voting?
            ganeti-wconfd-configuration-debug?
            ganeti-wconfd-service-type

            ganeti-luxid-configuration
            ganeti-luxid-configuration?
            ganeti-luxid-configuration-ganeti
            ganeti-luxid-configuration-no-voting?
            ganeti-luxid-configuration-debug?
            ganeti-luxid-service-type

            ganeti-rapi-configuration
            ganeti-rapi-configuration?
            ganeti-rapi-configuration-ganeti
            ganeti-rapi-configuration-require-authentication?
            ganeti-rapi-configuration-port
            ganeti-rapi-configuration-address
            ganeti-rapi-configuration-interface
            ganeti-rapi-configuration-max-clients
            ganeti-rapi-configuration-ssl?
            ganeti-rapi-configuration-ssl-key
            ganeti-rapi-configuration-ssl-cert
            ganeti-rapi-configuration-debug?
            ganeti-rapi-service-type

            ganeti-kvmd-configuration
            ganeti-kvmd-configuration?
            ganeti-kvmd-configuration-ganeti
            ganeti-kvmd-configuration-debug?
            ganeti-kvmd-service-type

            ganeti-mond-configuration
            ganeti-mond-configuration?
            ganeti-mond-configuration-ganeti
            ganeti-mond-configuration-port
            ganeti-mond-configuration-address
            ganeti-mond-configuration-debug?
            ganeti-mond-service-type

            ganeti-metad-configuration
            ganeti-metad-configuration?
            ganeti-metad-configuration-ganeti
            ganeti-metad-configuration-port
            ganeti-metad-configuration-address
            ganeti-metad-configuration-debug?
            ganeti-metad-service-type

            ganeti-watcher-configuration
            ganeti-watcher-configuration?
            ganeti-watcher-configuration-ganeti
            ganeti-watcher-configuration-schedule
            ganeti-watcher-configuration-rapi-ip
            ganeti-watcher-configuration-job-age
            ganeti-watcher-configuration-verify-disks?
            ganeti-watcher-configuration-debug?
            ganeti-watcher-service-type

            ganeti-cleaner-configuration
            ganeti-cleaner-configuration?
            ganeti-cleaner-configuration-ganeti
            ganeti-cleaner-configuration-master-schedule
            ganeti-cleaner-configuration-node-schedule
            ganeti-cleaner-service-type

            ganeti-os
            ganeti-os?
            ganeti-os-name
            ganeti-os-extension
            ganeti-os-variants

            ganeti-os-variant
            ganeti-os-variant?
            ganeti-os-variant-name
            ganeti-os-variant-configuration

            %debootstrap-interfaces-hook
            %debootstrap-grub-hook
            %default-debootstrap-hooks
            %default-debootstrap-extra-pkgs
            debootstrap-configuration
            debootstrap-configuration?
            debootstrap-configuration-hooks
            debootstrap-configuration-proxy
            debootstrap-configuration-mirror
            debootstrap-configuration-arch
            debootstrap-configuration-suite
            debootstrap-configuration-extra-pkgs
            debootstrap-configuration-components
            debootstrap-configuration-generate-cache?
            debootstrap-configuration-clean-cache
            debootstrap-configuration-partition-style
            debootstrap-configuration-partition-alignment

            debootstrap-variant
            debootstrap-os
            %default-debootstrap-variants

            guix-variant
            guix-os
            %default-guix-variants

            %default-ganeti-os

            ganeti-configuration
            ganeti-configuration?
            ganeti-configuration-noded-configuration
            ganeti-configuration-confd-configuration
            ganeti-configuration-wconfd-configuration
            ganeti-configuration-luxid-configuration
            ganeti-configuration-rapi-configuration
            ganeti-configuration-kvmd-configuration
            ganeti-configuration-mond-configuration
            ganeti-configuration-metad-configuration
            ganeti-configuration-watcher-configuration
            ganeti-configuration-cleaner-configuration
            ganeti-configuration-file-storage-paths
            ganeti-configuration-os
            ganeti-service-type))

;;;
;;; Service definitions for running a Ganeti cluster.
;;;
;;; Planned improvements: run daemons (except ganeti-noded) under unprivileged
;;; user accounts and/or containers.  The account names must match the ones
;;; given to Ganetis configure script.  metad needs "setcap" or root in order
;;; to bind on port 80.

;; Set PATH so the various daemons are able to find the 'ip' executable, LVM,
;; Ceph, Gluster, etc, without having to add absolute references to everything.
(define %default-ganeti-environment-variables
  (list (string-append "PATH="
                       (string-join '("/run/setuid-programs"
                                      "/run/current-system/profile/sbin"
                                      "/run/current-system/profile/bin")
                                    ":"))))

(define-record-type* <ganeti-noded-configuration>
  ganeti-noded-configuration make-ganeti-noded-configuration
  ganeti-noded-configuration?
  (ganeti      ganeti-noded-configuration-ganeti        ;<package>
               (default ganeti))
  (port        ganeti-noded-configuration-port          ;integer
               (default 1811))
  (address     ganeti-noded-configuration-address       ;string
               (default "0.0.0.0"))
  (interface   ganeti-noded-configuration-interface     ;string | #f
               (default #f))
  (max-clients ganeti-noded-configuration-max-clients   ;integer
               (default 20))
  (ssl?        ganeti-noded-configuration-ssl?          ;Boolean
               (default #t))
  (ssl-key     ganeti-noded-configuration-ssl-key       ;string
               (default "/var/lib/ganeti/server.pem"))
  (ssl-cert    ganeti-noded-configuration-ssl-cert      ;string
               (default "/var/lib/ganeti/server.pem"))
  (debug?      ganeti-noded-configuration-debug?        ;Boolean
               (default #f)))

(define ganeti-noded-service
  (match-lambda
    (($ <ganeti-noded-configuration> ganeti port address interface max-clients
                                     ssl? ssl-key ssl-cert debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti node daemon.")
            (provision '(ganeti-noded))
            (requirement '(user-processes networking))

            ;; If the daemon stops, it is probably for a good reason;
            ;; otherwise ganeti-watcher will restart it for us anyway.
            (respawn? #f)

            (start #~(make-forkexec-constructor
                      (list #$(file-append ganeti "/sbin/ganeti-noded")
                            #$(string-append "--port=" (number->string port))
                            #$(string-append "--bind=" address)
                            #$@(if interface
                                   #~((string-append "--interface=" #$interface))
                                   #~())
                            #$(string-append "--max-clients="
                                             (number->string max-clients))
                            #$@(if ssl?
                                   #~((string-append "--ssl-key=" #$ssl-key)
                                      (string-append "--ssl-cert=" #$ssl-cert))
                                   #~("--no-ssl"))
                            #$@(if debug?
                                   #~("--debug")
                                   #~()))
                      #:environment-variables
                      '#$%default-ganeti-environment-variables
                      #:pid-file "/var/run/ganeti/ganeti-noded.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-noded-service-type
  (service-type (name 'ganeti-noded)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-noded-service)))
                (default-value (ganeti-noded-configuration))
                (description
                 "@command{ganeti-noded} is the daemon which is responsible
for the node functions in the Ganeti system.")))

(define-record-type* <ganeti-confd-configuration>
  ganeti-confd-configuration make-ganeti-confd-configuration
  ganeti-confd-configuration?
  (ganeti      ganeti-confd-configuration-ganeti        ;<package>
               (default ganeti))
  (port        ganeti-confd-configuration-port          ;integer
               (default 1814))
  (address     ganeti-confd-configuration-address       ;string
               (default "0.0.0.0"))
  (debug?      ganeti-confd-configuration-debug?        ;Boolean
               (default #f)))

(define ganeti-confd-service
  (match-lambda
    (($ <ganeti-confd-configuration> ganeti port address debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti confd daemon.")
            (provision '(ganeti-confd))
            (requirement '(user-processes networking))
            (respawn? #f)
            (start #~(make-forkexec-constructor
                      (list #$(file-append ganeti "/sbin/ganeti-confd")
                            #$(string-append "--port=" (number->string port))
                            #$(string-append "--bind=" address)
                            #$@(if debug?
                                   #~("--debug")
                                   #~()))
                      #:environment-variables
                      '#$%default-ganeti-environment-variables
                      #:pid-file "/var/run/ganeti/ganeti-confd.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-confd-service-type
  (service-type (name 'ganeti-confd)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-confd-service)))
                (default-value (ganeti-confd-configuration))
                (description
                 "@command{ganeti-confd} is a daemon used to answer queries
related to the configuration of a Ganeti cluster.")))

(define-record-type* <ganeti-wconfd-configuration>
  ganeti-wconfd-configuration make-ganeti-wconfd-configuration
  ganeti-wconfd-configuration?
  (ganeti      ganeti-wconfd-configuration-ganeti       ;<package>
               (default ganeti))
  (no-voting?  ganeti-wconfd-configuration-no-voting?   ;Boolean
               (default #f))
  (debug?      ganeti-wconfd-configuration-debug?       ;Boolean
               (default #f)))

;; If this file exists, the wconfd daemon will be forcefully started even on
;; non-master nodes.  It is used to accommodate a master-failover scenario.
(define %wconfd-force-node-hint
  "/var/lib/ganeti/guix_wconfd_force_node_hint")

(define (wconfd-wrapper ganeti args)
  ;; Wrapper for the wconfd daemon that looks for the force-node hint.
  (program-file
   "wconfd-wrapper"
   #~(begin
       (let ((wconfd #$(file-append ganeti "/sbin/ganeti-wconfd"))
             (force-node? (file-exists? #$%wconfd-force-node-hint)))
         (if force-node?
             (execl wconfd wconfd "--force-node" "--no-voting" "--yes-do-it" #$@args)
             (execl wconfd wconfd #$@args))))))

(define shepherd-wconfd-force-start-action
  ;; Shepherd action to create the force-node hint and start wconfd.
  (shepherd-action
   (name 'force-start)
   (documentation
    "Forcefully start wconfd even on non-master nodes (dangerous!).")
   (procedure #~(lambda _
                  (format #t "Forcefully starting the wconfd daemon...~%")
                  (action 'ganeti-wconfd 'enable)
                  (dynamic-wind
                    (lambda ()
                      (false-if-exception
                       (call-with-output-file #$%wconfd-force-node-hint
                         (lambda (port)
                           (const #t)))))
                    (lambda ()
                      (action 'ganeti-wconfd 'restart))
                    (lambda ()
                      (delete-file #$%wconfd-force-node-hint)))
                    #t))))

(define ganeti-wconfd-service
  (match-lambda
    (($ <ganeti-wconfd-configuration> ganeti no-voting? debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti wconfd daemon.")
            (provision '(ganeti-wconfd))
            (requirement '(user-processes))

            ;; Shepherd action to support a master-failover scenario.  It is
            ;; automatically invoked during 'gnt-cluster master-failover' (see
            ;; related Ganeti patch) and not intended for interactive use.
            (actions (list shepherd-wconfd-force-start-action))

            ;; wconfd will disable itself when not running on the master
            ;; node.  Don't attempt to restart it.
            (respawn? #f)

            (start
             #~(make-forkexec-constructor
                (list #$(wconfd-wrapper ganeti
                                        (append
                                         (if no-voting?
                                             '("--no-voting" "--yes-do-it")
                                             '())
                                         (if debug?
                                             '("--debug")
                                             '()))))
                #:environment-variables
                '#$%default-ganeti-environment-variables
                #:pid-file "/var/run/ganeti/ganeti-wconfd.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-wconfd-service-type
  (service-type (name 'ganeti-wconfd)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-wconfd-service)))
                (default-value (ganeti-wconfd-configuration))
                (description
                 "@command{ganeti-wconfd} is the daemon that has authoritative
knowledge about the configuration and is the only entity that can accept changes
to it.  All jobs that need to modify the configuration will do so by sending
appropriate requests to this daemon.")))

(define-record-type* <ganeti-luxid-configuration>
  ganeti-luxid-configuration make-ganeti-luxid-configuration
  ganeti-luxid-configuration?
  (ganeti      ganeti-luxid-configuration-ganeti        ;<package>
               (default ganeti))
  (no-voting?  ganeti-luxid-configuration-no-voting?    ;Boolean
               (default #f))
  (debug?      ganeti-luxid-configuration-debug?        ;Boolean
               (default #f)))

(define ganeti-luxid-service
  (match-lambda
    (($ <ganeti-luxid-configuration> ganeti no-voting? debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti LUXI daemon.")
            (provision '(ganeti-luxid))
            (requirement '(user-processes))

            ;; This service will automatically disable itself when not
            ;; running on the master node.  Don't attempt to restart it.
            (respawn? #f)

            (start #~(make-forkexec-constructor
                      (list #$(file-append ganeti "/sbin/ganeti-luxid")
                            #$@(if no-voting?
                                   #~("--no-voting" "--yes-do-it")
                                   #~())
                            #$@(if debug?
                                   #~("--debug")
                                   #~()))
                      #:environment-variables
                      '#$%default-ganeti-environment-variables
                      #:pid-file "/var/run/ganeti/ganeti-luxid.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-luxid-service-type
  (service-type (name 'ganeti-luxid)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-luxid-service)))
                (default-value (ganeti-luxid-configuration))
                (description
                 "@command{ganeti-luxid} is a daemon used to answer queries
related to the configuration and the current live state of a Ganeti cluster.
Additionally, it is the autorative daemon for the Ganeti job queue.  Jobs can
be submitted via this daemon and it schedules and starts them.")))

(define-record-type* <ganeti-rapi-configuration>
  ganeti-rapi-configuration make-ganeti-rapi-configuration
  ganeti-rapi-configuration?
  (ganeti      ganeti-rapi-configuration-ganeti         ;<package>
               (default ganeti))
  (require-authentication?
   ganeti-rapi-configuration-require-authentication?    ;Boolean
   (default #f))
  (port        ganeti-rapi-configuration-port           ;integer
               (default 5080))
  (address     ganeti-rapi-configuration-address        ;string
               (default "0.0.0.0"))
  (interface   ganeti-rapi-configuration-interface      ;string | #f
               (default #f))
  (max-clients ganeti-rapi-configuration-max-clients    ;integer
               (default 20))
  (ssl?        ganeti-rapi-configuration-ssl?           ;Boolean
               (default #t))
  (ssl-key     ganeti-rapi-configuration-ssl-key        ;string
               (default "/var/lib/ganeti/server.pem"))
  (ssl-cert    ganeti-rapi-configuration-ssl-cert       ;string
               (default "/var/lib/ganeti/server.pem"))
  (debug?      ganeti-rapi-configuration-debug?         ;Boolean
               (default #f)))

(define ganeti-rapi-service
  (match-lambda
    (($ <ganeti-rapi-configuration> ganeti require-authentication? port address
                                    interface max-clients ssl? ssl-key ssl-cert
                                    debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti RAPI daemon.")
            (provision '(ganeti-rapi))
            (requirement '(user-processes networking))

            ;; This service will automatically disable itself when not
            ;; running on the master node.  Don't attempt to restart it.
            (respawn? #f)

            (start #~(make-forkexec-constructor
                      (list #$(file-append ganeti "/sbin/ganeti-rapi")
                            #$@(if require-authentication?
                                   #~("--require-authentication")
                                   #~())
                            #$(string-append "--port=" (number->string port))
                            #$(string-append "--bind=" address)
                            #$@(if interface
                                   #~((string-append "--interface=" #$interface))
                                   #~())
                            #$(string-append "--max-clients="
                                             (number->string max-clients))
                            #$@(if ssl?
                                   #~((string-append "--ssl-key=" #$ssl-key)
                                      (string-append "--ssl-cert=" #$ssl-cert))
                                   #~("--no-ssl"))
                            #$@(if debug?
                                   #~("--debug")
                                   #~()))
                      #:environment-variables
                      '#$%default-ganeti-environment-variables
                      #:pid-file "/var/run/ganeti/ganeti-rapi.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-rapi-service-type
  (service-type (name 'ganeti-rapi)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-rapi-service)))
                (default-value (ganeti-rapi-configuration))
                (description
                 "@command{ganeti-rapi} is the daemon providing a remote API
for Ganeti clusters.")))

(define-record-type* <ganeti-kvmd-configuration>
  ganeti-kvmd-configuration make-ganeti-kvmd-configuration
  ganeti-kvmd-configuration?
  (ganeti      ganeti-kvmd-configuration-ganeti         ;<package>
               (default ganeti))
  (debug?      ganeti-kvmd-configuration-debug?         ;Boolean
               (default #f)))

(define ganeti-kvmd-service
  (match-lambda
    (($ <ganeti-kvmd-configuration> ganeti debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti KVM daemon.")
            (provision '(ganeti-kvmd))
            (requirement '(user-processes))

            ;; This service will automatically disable itself when not
            ;; needed.  Don't attempt to restart it.
            (respawn? #f)

            (start #~(make-forkexec-constructor
                      (list #$(file-append ganeti "/sbin/ganeti-kvmd")
                            #$@(if debug?
                                   #~("--debug")
                                   #~()))
                      #:environment-variables
                      '#$%default-ganeti-environment-variables
                      #:pid-file "/var/run/ganeti/ganeti-kvmd.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-kvmd-service-type
  (service-type (name 'ganeti-kvmd)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-kvmd-service)))
                (default-value (ganeti-kvmd-configuration))
                (description
                 "@command{ganeti-kvmd} is responsible for determining whether
a given KVM instance was shutdown by an administrator or a user.

The KVM daemon monitors, using @code{inotify}, KVM instances through their QMP
sockets, which are provided by KVM.  Using the QMP sockets, the KVM daemon
listens for particular shutdown, powerdown, and stop events which will determine
if a given instance was shutdown by the user or Ganeti, and this result is
communicated to Ganeti via a special file in the file system.")))

(define-record-type* <ganeti-mond-configuration>
  ganeti-mond-configuration make-ganeti-mond-configuration
  ganeti-mond-configuration?
  (ganeti      ganeti-mond-configuration-ganeti         ;<package>
               (default ganeti))
  (port        ganeti-mond-configuration-port           ;integer
               (default 1815))
  (address     ganeti-mond-configuration-address        ;string
               (default "0.0.0.0"))
  (debug?      ganeti-mond-configuration-debug?         ;Boolean
               (default #f)))

(define ganeti-mond-service
  (match-lambda
    (($ <ganeti-mond-configuration> ganeti port address debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti monitoring daemon.")
            (provision '(ganeti-mond))
            (requirement '(user-processes networking))
            (respawn? #f)
            (start #~(make-forkexec-constructor
                      (list #$(file-append ganeti "/sbin/ganeti-mond")
                            #$(string-append "--port=" (number->string port))
                            #$(string-append "--bind=" address)
                            #$@(if debug?
                                   #~("--debug")
                                   #~()))
                      #:pid-file "/var/run/ganeti/ganeti-mond.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-mond-service-type
  (service-type (name 'ganeti-mond)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-mond-service)))
                (default-value (ganeti-mond-configuration))
                (description
                 "@command{ganeti-mond} is a daemon providing monitoring
functionality.  It is responsible for running the data collectors and to
provide the collected information through a HTTP interface.")))

(define-record-type* <ganeti-metad-configuration>
  ganeti-metad-configuration make-ganeti-metad-configuration
  ganeti-metad-configuration?
  (ganeti      ganeti-metad-configuration-ganeti        ;<package>
               (default ganeti))
  (port        ganeti-metad-configuration-port          ;integer
               (default 80))
  (address     ganeti-metad-configuration-address       ;string | #f
               (default #f))
  (debug?      ganeti-metad-configuration-debug?        ;Boolean
               (default #f)))

(define ganeti-metad-service
  (match-lambda
    (($ <ganeti-metad-configuration> ganeti port address debug?)
     (list (shepherd-service
            (documentation "Run the Ganeti metadata daemon.")
            (provision '(ganeti-metad))
            (requirement '(user-processes networking))
            (respawn? #f)
            (start #~(make-forkexec-constructor
                      (list #$(file-append ganeti "/sbin/ganeti-metad")
                            #$(string-append "--port=" (number->string port))
                            #$@(if address
                                   #~((string-append "--bind=" #$address))
                                   #~())
                            #$@(if debug?
                                   #~("--debug")
                                   #~()))
                      #:pid-file "/var/run/ganeti/ganeti-metad.pid"))
            (stop #~(make-kill-destructor)))))))

(define ganeti-metad-service-type
  (service-type (name 'ganeti-metad)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ganeti-metad-service)))
                (default-value (ganeti-metad-configuration))
                (description
                 "@command{ganeti-metad} is a daemon that can be used to pass
information to OS install scripts or instances.")))

(define-record-type* <ganeti-watcher-configuration>
  ganeti-watcher-configuration make-ganeti-watcher-configuration
  ganeti-watcher-configuration?
  (ganeti        ganeti-watcher-configuration-ganeti        ;<package>
                 (default ganeti))
  (schedule      ganeti-watcher-configuration-schedule      ;list | string
                 (default '(next-second-from
                            ;; Run every five minutes.
                            (next-minute (range 0 60 5)))))
  (rapi-ip       ganeti-watcher-configuration-rapi-ip       ;#f | string
                 (default #f))
  (job-age       ganeti-watcher-configuration-job-age       ;integer
                 (default (* 6 3600)))
  (verify-disks? ganeti-watcher-configuration-verify-disks? ;Boolean
                 (default #t))
  (debug?        ganeti-watcher-configuration-debug?        ;Boolean
                 (default #f)))

(define ganeti-watcher-command
  (match-lambda
    (($ <ganeti-watcher-configuration> ganeti _ rapi-ip job-age verify-disks?
                                       debug?)
     #~(lambda ()
         (system* #$(file-append ganeti "/sbin/ganeti-watcher")
                  #$@(if rapi-ip
                         #~((string-append "--rapi-ip=" #$rapi-ip))
                         #~())
                  #$(string-append "--job-age=" (number->string job-age))
                  #$@(if verify-disks?
                         #~()
                         #~("--no-verify-disks"))
                  #$@(if debug?
                         #~("--debug")
                         #~()))))))

(define (ganeti-watcher-jobs config)
  (match config
    (($ <ganeti-watcher-configuration> _ schedule)
     (list
      #~(job #$@(match schedule
                  ((? string?)
                   #~(#$schedule))
                  ((? list?)
                   #~('#$schedule)))
             #$(ganeti-watcher-command config))))))

(define ganeti-watcher-service-type
  (service-type (name 'ganeti-watcher)
                (extensions
                 (list (service-extension mcron-service-type
                                          ganeti-watcher-jobs)))
                (default-value (ganeti-watcher-configuration))
                (description
                 "@command{ganeti-watcher} is a periodically run script that
performs a number of maintenance actions on the cluster.  It will automatically
restart instances that are marked as ERROR_down, i.e., instances that should be
running, but are not; and it will also try to repair DRBD links in case a
secondary node has rebooted.  In addition it is responsible for archiving old
cluster jobs, and it will restart any down Ganeti daemons that are appropriate
for the current node.  If the cluster parameter @code{maintain_node_health} is
enabled, the watcher will also shutdown instances and DRBD devices if the node
is declared offline by known master candidates.")))

(define-record-type* <ganeti-cleaner-configuration>
  ganeti-cleaner-configuration make-ganeti-cleaner-configuration
  ganeti-cleaner-configuration?
  (ganeti          ganeti-cleaner-configuration-ganeti          ;<package>
                   (default ganeti))
  (master-schedule ganeti-cleaner-configuration-master-schedule ;list | string
                   ;; Run the master cleaner at 01:45 every day.
                   (default "45 1 * * *"))
  (node-schedule ganeti-cleaner-configuration-node-schedule     ;list | string
                   ;; Run the node cleaner at 02:45 every day.
                   (default "45 2 * * *")))

(define ganeti-cleaner-jobs
  (match-lambda
    (($ <ganeti-cleaner-configuration> ganeti master-schedule node-schedule)
     (list
      #~(job #$@(match master-schedule
                  ((? string?)
                   #~(#$master-schedule))
                  ((? list?)
                   #~('#$master-schedule)))
             (lambda ()
              (system* #$(file-append ganeti "/sbin/ganeti-cleaner")
                       "master")))
      #~(job #$@(match node-schedule
                  ((? string?)
                   #~(#$node-schedule))
                  ((? list?)
                   #~('#$node-schedule)))
             (lambda ()
               (system* #$(file-append ganeti "/sbin/ganeti-cleaner")
                        "node")))))))

(define ganeti-cleaner-service-type
  (service-type (name 'ganeti-cleaner)
                (extensions
                 (list (service-extension mcron-service-type
                                          ganeti-cleaner-jobs)))
                (default-value (ganeti-cleaner-configuration))
                (description
                 "@command{ganeti-cleaner} is a script that removes old files
from the cluster.  When called with @code{node} as argument it removes expired
X509 certificates and keys from @file{/var/run/ganeti/crypto}, as well as
outdated @command{ganeti-watcher} information.

When called with @code{master} as argument, it instead removes files older
than 21 days from @file{/var/lib/ganeti/queue/archive}.")))

(define-record-type* <ganeti-configuration>
  ganeti-configuration make-ganeti-configuration
  ganeti-configuration?
  (ganeti                 ganeti-configuration-ganeti
                          (default ganeti))
  (noded-configuration    ganeti-configuration-noded-configuration
                          (default (ganeti-noded-configuration)))
  (confd-configuration    ganeti-configuration-confd-configuration
                          (default (ganeti-confd-configuration)))
  (wconfd-configuration   ganeti-configuration-wconfd-configuration
                          (default (ganeti-wconfd-configuration)))
  (luxid-configuration    ganeti-configuration-luxid-configuration
                          (default (ganeti-luxid-configuration)))
  (rapi-configuration     ganeti-configuration-rapi-configuration
                          (default (ganeti-rapi-configuration)))
  (kvmd-configuration     ganeti-configuration-kvmd-configuration
                          (default (ganeti-kvmd-configuration)))
  (mond-configuration     ganeti-configuration-mond-configuration
                          (default (ganeti-mond-configuration)))
  (metad-configuration    ganeti-configuration-metad-configuration
                          (default (ganeti-metad-configuration)))
  (watcher-configuration  ganeti-configuration-watcher-configuration
                          (default (ganeti-watcher-configuration)))
  (cleaner-configuration  ganeti-configuration-cleaner-configuration
                          (default (ganeti-cleaner-configuration)))
  (file-storage-paths     ganeti-configuration-file-storage-paths ;list of strings | gexp
                          (default '()))
  (os                     ganeti-configuration-os  ;list of <ganeti-os>
                          (default '())))

(define (ganeti-activation config)
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))
        (for-each mkdir-p
                  '("/var/log/ganeti"
                    "/var/log/ganeti/kvm"
                    "/var/log/ganeti/os"
                    "/var/lib/ganeti/rapi"
                    "/var/lib/ganeti/queue"
                    "/var/lib/ganeti/queue/archive"
                    "/var/run/ganeti/bdev-cache"
                    "/var/run/ganeti/crypto"
                    "/var/run/ganeti/socket"
                    "/var/run/ganeti/instance-disks"
                    "/var/run/ganeti/instance-reason"
                    "/var/run/ganeti/livelocks")))))

(define ganeti-shepherd-services
  (match-lambda
    (($ <ganeti-configuration> _ noded confd wconfd luxid rapi kvmd mond metad)
     (append (ganeti-noded-service noded)
             (ganeti-confd-service confd)
             (ganeti-wconfd-service wconfd)
             (ganeti-luxid-service luxid)
             (ganeti-rapi-service rapi)
             (ganeti-kvmd-service kvmd)
             (ganeti-mond-service mond)
             (ganeti-metad-service metad)))))

(define ganeti-mcron-jobs
  (match-lambda
    (($ <ganeti-configuration> _ _ _ _ _ _ _ _ _ watcher cleaner)
     (append (ganeti-watcher-jobs watcher)
             (ganeti-cleaner-jobs cleaner)))))

(define-record-type* <ganeti-os>
  ganeti-os make-ganeti-os ganeti-os?
  (name ganeti-os-name)                     ;string
  (extension ganeti-os-extension)           ;string
  (variants ganeti-os-variants              ;list of <ganeti-os-variant>
            (default '())))

(define-record-type* <ganeti-os-variant>
  ganeti-os-variant make-ganeti-os-variant ganeti-os-variant?
  (name ganeti-os-variant-name)                       ;string
  (configuration ganeti-os-variant-configuration))    ;<file-like>

(define %debootstrap-interfaces-hook
  (file-append ganeti-instance-debootstrap
               "/share/doc/ganeti-instance-debootstrap/examples/interfaces"))

;; The GRUB hook shipped with instance-debootstrap does not work with GRUB2.
;; For convenience, provide one that work with modern Debians here.
;; Note: it would be neat to reuse Guix' bootloader infrastructure instead.
(define %debootstrap-grub-hook
  (plain-file "grub"
              "#!/usr/bin/env bash
CLEANUP=( )
cleanup() {
  if [ ${#CLEANUP[*]} -gt 0 ]; then
    LAST_ELEMENT=$((${#CLEANUP[*]}-1))
    REVERSE_INDEXES=$(seq ${LAST_ELEMENT} -1 0)
    for i in $REVERSE_INDEXES; do
      ${CLEANUP[$i]}
    done
  fi
}

trap cleanup EXIT

mount -t proc proc $TARGET/proc
CLEANUP+=(\"umount $TARGET/proc\")
mount -t sysfs sysfs $TARGET/sys
CLEANUP+=(\"umount $TARGET/sys\")
mount -o bind /dev $TARGET/dev
CLEANUP+=(\"umount $TARGET/dev\")

echo '
GRUB_TIMEOUT_STYLE=menu
GRUB_CMDLINE_LINUX_DEFAULT=\"console=ttyS0,115200 net.ifnames=0\"
GRUB_TERMINAL=\"serial\"
GRUB_SERIAL_COMMAND=\"serial --unit=0 --speed=115200\"
' >> $TARGET/etc/default/grub

# This PATH is propagated into the chroot and necessary to make grub-install
# and related commands visible.
export PATH=\"/usr/sbin:/usr/bin:/sbin:/bin:$PATH\"

chroot \"$TARGET\" grub-install $BLOCKDEV
chroot \"$TARGET\" update-grub

cleanup
trap - EXIT
"))

(define %default-debootstrap-hooks
  `((10-interfaces . ,%debootstrap-interfaces-hook)
    (90-grub . ,%debootstrap-grub-hook)))

(define %default-debootstrap-extra-pkgs
  ;; Packages suitable for a fully virtualized KVM guest.
  '("acpi-support-base" "udev" "linux-image-amd64" "openssh-server"
    "locales-all" "grub-pc"))

(define-record-type* <debootstrap-configuration>
  debootstrap-configuration make-debootstrap-configuration
  debootstrap-configuration?
  (hooks debootstrap-configuration-hooks                     ;#f | gexp | '((name . gexp))
         (default %default-debootstrap-hooks))
  (proxy debootstrap-configuration-proxy (default #f))       ;#f | string
  (mirror debootstrap-configuration-mirror                   ;#f | string
          (default #f))
  (arch debootstrap-configuration-arch (default #f))         ;#f | string
  (suite debootstrap-configuration-suite                     ;#f | string
         (default "stable"))
  (extra-pkgs debootstrap-configuration-extra-pkgs           ;list of strings
              (default %default-debootstrap-extra-pkgs))
  (components debootstrap-configuration-components           ;list of strings
              (default '()))
  (generate-cache? debootstrap-configuration-generate-cache? ;Boolean
                   (default #t))
  (clean-cache debootstrap-configuration-clean-cache         ;#f | integer
               (default 14))
  (partition-style debootstrap-configuration-partition-style ;#f | symbol | string
                   (default 'msdos))
  (partition-alignment debootstrap-configuration-partition-alignment ;#f | integer
                       (default 2048)))

(define (hooks->directory hooks)
  (match hooks
    ((? file-like?)
     hooks)
    ((? list?)
     (let ((names (map car hooks))
           (files (map cdr hooks)))
       (with-imported-modules '((guix build utils))
         (computed-file "hooks-union"
                        #~(begin
                            (use-modules (guix build utils)
                                         (ice-9 match))
                            (mkdir-p #$output)
                            (with-directory-excursion #$output
                              (for-each (match-lambda
                                          ((name hook)
                                           (let ((file-name (string-append
                                                             #$output "/"
                                                             (symbol->string name))))
                                             ;; Copy to the destination to ensure
                                             ;; the file is executable.
                                             (copy-file hook file-name)
                                             (chmod file-name #o555))))
                                        '#$(zip names files))))))))
    (_ #f)))

(define-gexp-compiler (debootstrap-configuration-compiler
                       (file <debootstrap-configuration>) system target)
  (match file
    (($ <debootstrap-configuration> hooks proxy mirror arch suite extra-pkgs
                                    components generate-cache? clean-cache
                                    partition-style partition-alignment)
     (let ((customize-dir (hooks->directory hooks)))
       (gexp->derivation
        "debootstrap-variant"
        #~(call-with-output-file (ungexp output "out")
            (lambda (port)
              (display
               (string-append
                (ungexp-splicing
                 `(,@(if proxy
                          `("PROXY=" ,proxy "\n")
                          '())
                    ,@(if mirror
                          `("MIRROR=" ,mirror "\n")
                          '())
                    ,@(if arch
                          `("ARCH=" ,arch "\n")
                          '())
                    ,@(if suite
                          `("SUITE=" ,suite "\n")
                          '())
                    ,@(if (not (null? extra-pkgs))
                          `("EXTRA_PKGS=" ,(string-join extra-pkgs ",") "\n")
                          '())
                    ,@(if (not (null? components))
                          `("COMPONENTS=" ,(string-join components ",") "\n")
                          '())
                    ,@(if customize-dir
                          `("CUSTOMIZE_DIR=" ,customize-dir "\n")
                          '())
                    ,@(if generate-cache?
                          '("GENERATE_CACHE=yes\n")
                          '("GENERATE_CACHE=no\n"))
                    ,@(if clean-cache
                          `("CLEAN_CACHE=" ,(number->string clean-cache) "\n")
                          '())
                    ,@(if partition-style
                          (if (symbol? partition-style)
                              `("PARTITION_STYLE="
                                ,(symbol->string partition-style) "\n")
                              `("PARTITION_STYLE=" ,partition-style "\n"))
                          '())
                    ,@(if partition-alignment
                          `("PARTITION_ALIGNMENT="
                            ,(number->string partition-alignment) "\n")
                          '()))))
               port)))
        #:local-build? #t)))))

(define (ganeti-os->directory os)
  "Return the derivation to build the configuration directory to be installed
in /etc/ganeti/instance-$os for OS."
  (let* ((name      (ganeti-os-name os))
         (extension (ganeti-os-extension os))
         (variants  (ganeti-os-variants os))
         (names     (map ganeti-os-variant-name variants))
         (configs   (map ganeti-os-variant-configuration variants)))
    (with-imported-modules '((guix build utils))
      (define builder
        #~(begin
            (use-modules (guix build utils)
                         (ice-9 format)
                         (ice-9 match)
                         (srfi srfi-1))
            (mkdir-p #$output)
            (unless (null? '#$names)
              (let ((variants-dir (string-append #$output "/variants")))
                (mkdir-p variants-dir)
                (call-with-output-file (string-append variants-dir "/variants.list")
                  (lambda (port)
                    (format port "~a~%"
                            (string-join '#$names "\n"))))
                (for-each (match-lambda
                            ((name file)
                             (symlink file
                                      (string-append variants-dir "/" name
                                                     #$extension))))

                          '#$(zip names configs))))))

      (computed-file (string-append name "-os") builder))))

(define (ganeti-directory file-storage-file os)
  (let ((dirs (map ganeti-os->directory os))
        (names (map ganeti-os-name os)))
    (define builder
      #~(begin
          (use-modules (ice-9 match))
          (mkdir #$output)
          (when #$file-storage-file
            (symlink #$file-storage-file
                     (string-append #$output "/file-storage-paths")))
          (for-each (match-lambda
                      ((name dest)
                       (symlink dest
                                (string-append #$output "/instance-" name))))
                    '#$(zip names dirs))))
    (computed-file "etc-ganeti" builder)))

(define (file-storage-file paths)
  (match paths
    ((? null?) #f)
    ((? list?) (plain-file
                "file-storage-paths"
                (string-join paths "\n")))
    (_ paths)))

(define (ganeti-etc-service config)
  (list `("ganeti" ,(ganeti-directory
                     (file-storage-file
                      (ganeti-configuration-file-storage-paths config))
                     (ganeti-configuration-os config)))))

(define (debootstrap-os variants)
  (ganeti-os
   (name "debootstrap")
   (extension ".conf")
   (variants variants)))

(define (debootstrap-variant name configuration)
  (ganeti-os-variant
   (name name)
   (configuration configuration)))

(define %default-debootstrap-variants
  (list (debootstrap-variant
         "default"
         (debootstrap-configuration))))

(define (guix-os variants)
  (ganeti-os
   (name "guix")
   (extension ".scm")
   (variants variants)))

(define (guix-variant name configuration)
  (ganeti-os-variant
   (name name)
   (configuration configuration)))

(define %default-guix-variants
  (list (guix-variant
         "default"
         (file-append ganeti-instance-guix
                      "/share/doc/ganeti-instance-guix/examples/dynamic.scm"))))

;; The OS configurations usually come with a default OS.  To make them work
;; out of the box, follow suit.
(define %default-ganeti-os
  (list (debootstrap-os %default-debootstrap-variants)
        (guix-os %default-guix-variants)))

(define ganeti-service-type
  (service-type (name 'ganeti)
                (extensions
                 (list (service-extension activation-service-type
                                          ganeti-activation)
                       (service-extension shepherd-root-service-type
                                          ganeti-shepherd-services)
                       (service-extension etc-service-type
                                          ganeti-etc-service)
                       (service-extension profile-service-type
                                          (compose list ganeti-configuration-ganeti))
                       (service-extension mcron-service-type
                                          ganeti-mcron-jobs)))
                (default-value (ganeti-configuration (os %default-ganeti-os)))
                (description
                 "Ganeti is a family of services that are designed to run
on a fleet of machines and facilitate deployment and maintenance of virtual
servers (@dfn{instances}).  It can migrate instances between nodes, automatically
restart failed instances, evacuate nodes, and much more.")))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Christopher Baines <mail@cbaines.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 getmail)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages mail)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages tls)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:export (getmail-retriever-configuration
            getmail-retriever-configuration-extra-parameters
            getmail-destination-configuration
            getmail-options-configuration
            getmail-configuration-file
            getmail-configuration
            getmail-service-type))

;;; Commentary:
;;;
;;; Service for the getmail mail retriever.
;;;
;;; Code:

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

(define (serialize-field field-name val)
  #~(let ((val '#$val))
      (format #f "~a = ~a\n"
              #$(uglify-field-name field-name)
              (cond
               ((list? val)
                (string-append
                 "("
                 (string-concatenate
                  (map (lambda (list-val)
                         (format #f "\"~a\", " list-val))
                       val))
                 ")"))
               (else
                val)))))

(define (serialize-string field-name val)
  (if (string=? val "")
      ""
      (serialize-field field-name val)))

(define (string-or-filelike? val)
  (or (string? val)
      (file-like? val)))
(define (serialize-string-or-filelike field-name val)
  (if (equal? val "")
      ""
      (serialize-field field-name val)))

(define (serialize-boolean field-name val)
  (serialize-field field-name (if val "true" "false")))

(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 serialize-list serialize-field)

(define parameter-alist? list?)
(define (serialize-parameter-alist field-name val)
  #~(string-append
     #$@(map (match-lambda
               ((key . value)
                (serialize-field key value)))
             val)))

(define (serialize-getmail-retriever-configuration field-name val)
  (serialize-configuration val getmail-retriever-configuration-fields))

(define-configuration getmail-retriever-configuration
  (type
   (string "SimpleIMAPSSLRetriever")
   "The type of mail retriever to use.  Valid values include
@samp{passwd} and @samp{static}.")
  (server
   (string 'unset)
   "Name or IP address of the server to retrieve mail from.")
  (username
   (string 'unset)
   "Username to login to the mail server with.")
  (port
   (non-negative-integer #f)
   "Port number to connect to.")
  (password
   (string "")
   "Override fields from passwd.")
  (password-command
   (list '())
   "Override fields from passwd.")
  (keyfile
   (string "")
   "PEM-formatted key file to use for the TLS negotiation.")
  (certfile
   (string "")
   "PEM-formatted certificate file to use for the TLS negotiation.")
  (ca-certs
   (string "")
   "CA certificates to use.")
  (extra-parameters
   (parameter-alist '())
   "Extra retriever parameters."))

(define (serialize-getmail-destination-configuration field-name val)
  (serialize-configuration val getmail-destination-configuration-fields))

(define-configuration getmail-destination-configuration
  (type
   (string 'unset)
   "The type of mail destination.  Valid values include @samp{Maildir},
@samp{Mboxrd} and @samp{MDA_external}.")
  (path
   (string-or-filelike "")
   "The path option for the mail destination.  The behaviour depends on the
chosen type.")
  (extra-parameters
   (parameter-alist '())
   "Extra destination parameters"))

(define (serialize-getmail-options-configuration field-name val)
  (serialize-configuration val getmail-options-configuration-fields))

(define-configuration getmail-options-configuration
  (verbose
   (non-negative-integer 1)
   "If set to @samp{0}, getmail will only print warnings and errors.  A value
of @samp{1} means that messages will be printed about retrieving and deleting
messages. If set to @samp{2}, getmail will print messages about each of it's
actions.")
  (read-all
   (boolean #t)
   "If true, getmail will retrieve all available messages.  Otherwise it will
only retrieve messages it hasn't seen previously.")
  (delete
   (boolean #f)
   "If set to true, messages will be deleted from the server after retrieving
and successfully delivering them.  Otherwise, messages will be left on the
server.")
  (delete-after
   (non-negative-integer 0)
   "Getmail will delete messages this number of days after seeing them, if
they have been delivered.  This means messages will be left on the server this
number of days after delivering them.  A value of @samp{0} disabled this
feature.")
  (delete-bigger-than
   (non-negative-integer 0)
   "Delete messages larger than this of bytes after retrieving them, even if
the delete and delete-after options are disabled.  A value of @samp{0}
disables this feature.")
  (max-bytes-per-session
   (non-negative-integer 0)
   "Retrieve messages totalling up to this number of bytes before closing the
session with the server.  A value of @samp{0} disables this feature.")
  (max-message-size
   (non-negative-integer 0)
   "Don't retrieve messages larger than this number of bytes.  A value of
@samp{0} disables this feature.")
  (delivered-to
   (boolean #t)
   "If true, getmail will add a Delivered-To header to messages.")
  (received
   (boolean #t)
   "If set, getmail adds a Received header to the messages.")
  (message-log
   (string "")
   "Getmail will record a log of its actions to the named file.  A value of
@samp{\"\"} disables this feature.")
  (message-log-syslog
   (boolean #f)
   "If true, getmail will record a log of its actions using the system
logger.")
  (message-log-verbose
   (boolean #f)
   "If true, getmail will log information about messages not retrieved and the
reason for not retrieving them, as well as starting and ending information
lines.")
  (extra-parameters
   (parameter-alist '())
   "Extra options to include."))

(define (serialize-getmail-configuration-file field-name val)
  (match val
    (($ <getmail-configuration-file> location
                                     retriever destination options)
     #~(string-append
        "[retriever]\n"
        #$(serialize-getmail-retriever-configuration #f retriever)
        "\n[destination]\n"
        #$(serialize-getmail-destination-configuration #f destination)
        "\n[options]\n"
        #$(serialize-getmail-options-configuration #f options)))))

(define-configuration getmail-configuration-file
  (retriever
   (getmail-retriever-configuration (getmail-retriever-configuration))
   "What mail account to retrieve mail from, and how to access that account.")
  (destination
   (getmail-destination-configuration (getmail-destination-configuration))
   "What to do with retrieved messages.")
  (options
   (getmail-options-configuration (getmail-options-configuration))
   "Configure getmail."))

(define (serialize-symbol field-name val) "")
(define (serialize-getmail-configuration field-name val) "")

(define-configuration getmail-configuration
  (name
   (symbol "unset")
   "A symbol to identify the getmail service.")
  (package
   (package getmail)
   "The getmail package to use.")
  (user
   (string "getmail")
   "The user to run getmail as.")
  (group
   (string "getmail")
   "The group to run getmail as.")
  (directory
   (string "/var/lib/getmail/default")
   "The getmail directory to use.")
  (rcfile
   (getmail-configuration-file (getmail-configuration-file))
   "The getmail configuration file to use.")
  (idle
   (list '())
   "A list of mailboxes that getmail should wait on the server for new mail
notifications.  This depends on the server supporting the IDLE extension.")
  (environment-variables
   (list '())
   "Environment variables to set for getmail."))

(define (generate-getmail-documentation)
  (generate-documentation
   `((getmail-configuration
      ,getmail-configuration-fields
      (rcfile getmail-configuration-file))
     (getmail-configuration-file
      ,getmail-configuration-file-fields
      (retriever getmail-retriever-configuration)
      (destination getmail-destination-configuration)
      (options getmail-options-configuration))
     (getmail-retriever-configuration ,getmail-retriever-configuration-fields)
     (getmail-destination-configuration ,getmail-destination-configuration-fields)
     (getmail-options-configuration ,getmail-options-configuration-fields))
   'getmail-configuration))

(define-gexp-compiler (getmail-configuration-file-compiler
                       (rcfile <getmail-configuration-file>) system target)
  (gexp->derivation
   "getmailrc"
   #~(call-with-output-file #$output
       (lambda (port)
         (display #$(serialize-getmail-configuration-file #f rcfile)
                  port)))
   #:system system
   #:target target))

(define (getmail-accounts configs)
  (let ((users (delete-duplicates
                (map getmail-configuration-user
                     configs)))
        (groups (delete-duplicates
                 (map getmail-configuration-group
                      configs))))
    (append
     (map (lambda (group)
            (user-group
             (name group)
             (system? #t)))
          groups)
     (map (lambda (user)
            (user-account
             (name user)
             (group (getmail-configuration-group
                     (find (lambda (config)
                             (and
                              (string=? user (getmail-configuration-user config))
                              (getmail-configuration-group config)))
                           configs)))
             (system? #t)
             (comment "Getmail user")
             (home-directory "/var/empty")
             (shell (file-append shadow "/sbin/nologin"))))
          users))))

(define (getmail-activation configs)
  "Return the activation GEXP for CONFIGS."
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))
        #$@(map
            (lambda (config)
              #~(let* ((pw (getpw #$(getmail-configuration-user config)))
                       (uid (passwd:uid pw))
                       (gid (passwd:gid pw))
                       (getmaildir #$(getmail-configuration-directory config)))
                  (mkdir-p getmaildir)
                  (chown getmaildir uid gid)))
            configs))))

(define (getmail-shepherd-services configs)
  "Return a list of <shepherd-service> for CONFIGS."
  (map (match-lambda
         (($ <getmail-configuration> location name package
                                     user group directory rcfile idle
                                     environment-variables)
          (shepherd-service
           (documentation "Run getmail.")
           (provision (list (symbol-append 'getmail- name)))
           (requirement '(networking))
           (start #~(make-forkexec-constructor
                     `(#$(file-append package "/bin/getmail")
                       ,(string-append "--getmaildir=" #$directory)
                       #$@(map (lambda (idle)
                                 (string-append "--idle=" idle))
                               idle)
                       ,(string-append "--rcfile=" #$rcfile))
                     #:user #$user
                     #:group #$group
                     #:environment-variables
                     (list #$@environment-variables)
                     #:log-file
                     #$(string-append "/var/log/getmail-"
                                      (symbol->string name))))
           (stop #~(make-kill-destructor)))))
       configs))

(define getmail-service-type
  (service-type
   (name 'getmail)
   (extensions
    (list (service-extension shepherd-root-service-type
                             getmail-shepherd-services)
          (service-extension activation-service-type
                             getmail-activation)
          (service-extension account-service-type
                             getmail-accounts)))
   (description
    "Run @command{getmail}, a mail retriever program.")
   (default-value '())
   (compose concatenate)
   (extend append)))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Christopher Baines <mail@cbaines.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 guix)
  #:use-module (ice-9 match)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module ((gnu packages base)
                #:select (glibc-utf8-locales))
  #:use-module (gnu packages admin)
  #:use-module (gnu packages web)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services admin)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services getmail)
  #:use-module (gnu system shadow)
  #:export (<guix-data-service-configuration>
            guix-data-service-configuration
            guix-data-service-configuration?
            guix-data-service-package
            guix-data-service-user
            guix-data-service-group
            guix-data-service-port
            guix-data-service-host
            guix-data-service-getmail-idle-mailboxes
            guix-data-service-commits-getmail-retriever-configuration

            guix-data-service-type))

;;;; Commentary:
;;;
;;; This module implements a service that to run instances of the Guix Data
;;; Service, which provides data about Guix over time.
;;;
;;;; Code:

(define-record-type* <guix-data-service-configuration>
  guix-data-service-configuration make-guix-data-service-configuration
  guix-data-service-configuration?
  (package          guix-data-service-package
                    (default guix-data-service))
  (user             guix-data-service-configuration-user
                    (default "guix-data-service"))
  (group            guix-data-service-configuration-group
                    (default "guix-data-service"))
  (port             guix-data-service-port
                    (default 8765))
  (host             guix-data-service-host
                    (default "127.0.0.1"))
  (getmail-idle-mailboxes
   guix-data-service-getmail-idle-mailboxes
   (default #f))
  (commits-getmail-retriever-configuration
   guix-data-service-commits-getmail-retriever-configuration
   (default #f))
  (extra-options    guix-data-service-extra-options
                    (default '()))
  (extra-process-jobs-options
   guix-data-service-extra-process-jobs-options
   (default '())))

(define (guix-data-service-profile-packages config)
  "Return the guix-data-service package, this will populate the
ca-certificates.crt file in the system profile."
  (list
   (guix-data-service-package config)))

(define (guix-data-service-shepherd-services config)
  (match-record config <guix-data-service-configuration>
    (package user group port host extra-options extra-process-jobs-options)
    (list
     (shepherd-service
      (documentation "Guix Data Service web server")
      (provision '(guix-data-service))
      (requirement '(postgres networking))
      (start #~(make-forkexec-constructor
                (list #$(file-append package
                                     "/bin/guix-data-service")
                      "--pid-file=/var/run/guix-data-service/pid"
                      #$(string-append "--port=" (number->string port))
                      #$(string-append "--host=" host)
                      ;; Perform any database migrations when the
                      ;; service is started
                      "--update-database"
                      #$@extra-options)

                #:user #$user
                #:group #$group
                #:pid-file "/var/run/guix-data-service/pid"
                ;; Allow time for migrations to run
                #:pid-file-timeout 60
                #:environment-variables
                `(,(string-append
                    "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
                  "LC_ALL=en_US.utf8")
                #:log-file "/var/log/guix-data-service/web.log"))
      (stop #~(make-kill-destructor)))

     (shepherd-service
      (documentation "Guix Data Service process jobs")
      (provision '(guix-data-service-process-jobs))
      (requirement '(postgres
                     networking
                     ;; Require guix-data-service, as that the database
                     ;; migrations are handled through this service
                     guix-data-service))
      (start #~(make-forkexec-constructor
                (list
                 #$(file-append package
                                "/bin/guix-data-service-process-jobs")
                 #$@extra-process-jobs-options)
                #:user #$user
                #:group #$group
                #:environment-variables
                `("HOME=/var/lib/guix-data-service"
                  "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
                  ,(string-append
                    "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale")
                  "LC_ALL=en_US.utf8")
                #:log-file "/var/log/guix-data-service/process-jobs.log"))
      (stop #~(make-kill-destructor))))))

(define (guix-data-service-activation config)
  #~(begin
      (use-modules (guix build utils))

      (define %user (getpw "guix-data-service"))

      (chmod "/var/lib/guix-data-service" #o755)

      (mkdir-p "/var/log/guix-data-service")

      ;; Allow writing the PID file
      (mkdir-p "/var/run/guix-data-service")
      (chown "/var/run/guix-data-service"
             (passwd:uid %user)
             (passwd:gid %user))))

(define (guix-data-service-account config)
  (match-record config <guix-data-service-configuration>
    (user group)
    (list (user-group
           (name group)
           (system? #t))
          (user-account
           (name user)
           (group group)
           (system? #t)
           (comment "Guix Data Service user")
           (home-directory "/var/lib/guix-data-service")
           (shell (file-append shadow "/sbin/nologin"))))))

(define (guix-data-service-getmail-configuration config)
  (match config
    (($ <guix-data-service-configuration> package user group
                                          port host
                                          #f #f)
     '())
    (($ <guix-data-service-configuration> package user group
                                          port host
                                          getmail-idle-mailboxes
                                          commits-getmail-retriever-configuration)
     (list
      (getmail-configuration
       (name 'guix-data-service)
       (user user)
       (group group)
       (directory "/var/lib/getmail/guix-data-service")
       (rcfile
        (getmail-configuration-file
         (retriever commits-getmail-retriever-configuration)
         (destination
          (getmail-destination-configuration
           (type "MDA_external")
           (path (file-append
                  package
                  "/bin/guix-data-service-process-branch-updated-email"))))
         (options
          (getmail-options-configuration
           (read-all #f)
           (delivered-to #f)
           (received #f)))))
       (idle getmail-idle-mailboxes))))))

(define guix-data-service-type
  (service-type
   (name 'guix-data-service)
   (extensions
    (list
     (service-extension profile-service-type
                        guix-data-service-profile-packages)
     (service-extension shepherd-root-service-type
                        guix-data-service-shepherd-services)
     (service-extension activation-service-type
                        guix-data-service-activation)
     (service-extension account-service-type
                        guix-data-service-account)
     (service-extension getmail-service-type
                        guix-data-service-getmail-configuration)))
   (default-value
     (guix-data-service-configuration))
   (description
    "Run an instance of the Guix Data Service.")))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2020 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 herd)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (%shepherd-socket-file
            shepherd-message-port

            shepherd-error?
            service-not-found-error?
            service-not-found-error-service
            action-not-found-error?
            action-not-found-error-service
            action-not-found-error-action
            action-exception-error?
            action-exception-error-service
            action-exception-error-action
            action-exception-error-key
            action-exception-error-arguments
            unknown-shepherd-error?
            unknown-shepherd-error-sexp

            live-service
            live-service?
            live-service-provision
            live-service-requirement
            live-service-running
            live-service-canonical-name

            with-shepherd-action
            current-services
            unload-services
            unload-service
            load-services
            load-services/safe
            start-service
            stop-service
            restart-service))

;;; Commentary:
;;;
;;; This module provides an interface to the GNU Shepherd, similar to the
;;; 'herd' command.  Essentially it implements a subset of the (shepherd comm)
;;; module, but focusing only on the parts relevant to 'guix system
;;; reconfigure'.
;;;
;;; Code:

(define %shepherd-socket-file
  (make-parameter "/var/run/shepherd/socket"))

(define* (open-connection #:optional (file (%shepherd-socket-file)))
  "Open a connection to the daemon, using the Unix-domain socket at FILE, and
return the socket."
  ;; The protocol is sexp-based and UTF-8-encoded.
  (with-fluids ((%default-port-encoding "UTF-8"))
    (let ((sock    (socket PF_UNIX SOCK_STREAM 0))
          (address (make-socket-address PF_UNIX file)))
      (catch 'system-error
        (lambda ()
          (connect sock address)
          (setvbuf sock 'block 1024)
          sock)
        (lambda args
          (close-port sock)
          (apply throw args))))))

(define-syntax-rule (with-shepherd connection body ...)
  "Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
  (let ((connection (open-connection)))
    (dynamic-wind
      (const #t)
      (lambda ()
        body ...)
      (lambda ()
        (close-port connection)))))

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

(define-condition-type &service-not-found-error &shepherd-error
  service-not-found-error?
  (service service-not-found-error-service))

(define-condition-type &action-not-found-error &shepherd-error
  action-not-found-error?
  (service action-not-found-error-service)
  (action  action-not-found-error-action))

(define-condition-type &action-exception-error &shepherd-error
  action-exception-error?
  (service action-exception-error-service)
  (action  action-exception-error-action)
  (key     action-exception-error-key)
  (args    action-exception-error-arguments))

(define-condition-type &unknown-shepherd-error &shepherd-error
  unknown-shepherd-error?
  (sexp   unknown-shepherd-error-sexp))

(define (raise-shepherd-error error)
  "Raise an error condition corresponding to ERROR, an sexp received by a
shepherd client in reply to COMMAND, a command object.  Return #t if ERROR
does not denote an error."
  (match error
    (('error ('version 0 x ...) 'service-not-found service)
     (raise (condition (&service-not-found-error
                        (service service)))))
    (('error ('version 0 x ...) 'action-not-found action service)
     (raise (condition (&action-not-found-error
                        (service service)
                        (action action)))))
    (('error ('version 0 x ...) 'action-exception action service
             key (args ...))
     (raise (condition (&action-exception-error
                        (service service)
                        (action action)
                        (key key) (args args)))))
    (('error . _)
     (raise (condition (&unknown-shepherd-error (sexp error)))))
    (#f                                           ;not an error
     #t)))

(define shepherd-message-port
  ;; Port where messages coming from shepherd are printed.
  (make-parameter (current-error-port)))

(define (display-message message)
  (format (shepherd-message-port) "shepherd: ~a~%" message))

(define* (invoke-action service action arguments cont)
  "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
list of results (one result per instance with the name SERVICE).  Otherwise
return #f."
  (with-shepherd sock
    (write `(shepherd-command (version 0)
                              (action ,action)
                              (service ,service)
                              (arguments ,arguments)
                              (directory ,(getcwd)))
           sock)
    (force-output sock)

    (match (read sock)
      (('reply ('version 0 _ ...) ('result result) ('error #f)
               ('messages messages))
       (for-each display-message messages)
       (cont result))
      (('reply ('version 0 x ...) ('result y) ('error error)
               ('messages messages))
       (for-each display-message messages)
       (raise-shepherd-error error)
       #f)
      (x
       ;; invalid reply
       #f))))

(define-syntax-rule (with-shepherd-action service (action args ...)
                      result body ...)
  "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT
bound to the action's result."
  (invoke-action service action (list args ...)
                 (lambda (result) body ...)))

(define-syntax alist-let*
  (syntax-rules ()
    "Bind the given KEYs in EXP to the corresponding items in ALIST.  ALIST
is assumed to be a list of two-element tuples rather than a traditional list
of pairs."
    ((_ alist (key ...) exp ...)
     (let ((key (and=> (assoc-ref alist 'key) car)) ...)
       exp ...))))

;; Information about live Shepherd services.
(define-record-type <live-service>
  (live-service provision requirement running)
  live-service?
  (provision    live-service-provision)           ;list of symbols
  (requirement  live-service-requirement)         ;list of symbols
  (running      live-service-running))            ;#f | object

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

(define (current-services)
  "Return the list of currently defined Shepherd services, represented as
<live-service> objects.  Return #f if the list of services could not be
obtained."
  (with-shepherd-action 'root ('status) results
    ;; We get a list of results, one for each service with the name 'root'.
    ;; In practice there's only one such service though.
    (match results
      ((services _ ...)
       (match services
         ((('service ('version 0 _ ...) _ ...) ...)
          (map (lambda (service)
                 (alist-let* service (provides requires running)
                   (live-service provides requires running)))
               services))
         (x
          #f))))))

(define (unload-service service)
  "Unload SERVICE, a symbol name; return #t on success."
  (with-shepherd-action 'root ('unload (symbol->string service)) result
    (first result)))

(define (%load-file file)
  "Load FILE in the Shepherd."
  (with-shepherd-action 'root ('load file) result
    (first result)))

(define (eval-there exp)
  "Eval EXP in the Shepherd."
  (with-shepherd-action 'root ('eval (object->string exp)) result
    (first result)))

(define (load-services files)
  "Load and register the services from FILES, where FILES contain code that
returns a shepherd <service> object."
  (eval-there `(register-services
                ,@(map (lambda (file)
                         `(primitive-load ,file))
                       files))))

(define (load-services/safe files)
  "This is like 'load-services', but make sure only the subset of FILES that
can be safely reloaded is actually reloaded.

This is done to accommodate the Shepherd < 0.15.0 where services lacked the
'replacement' slot, and where 'register-services' would throw an exception
when passed a service with an already-registered name."
  (eval-there `(let* ((services     (map primitive-load ',files))
                      (slots        (map slot-definition-name
                                         (class-slots <service>)))
                      (can-replace? (memq 'replacement slots)))
                 (define (registered? service)
                   (not (null? (lookup-services (canonical-name service)))))

                 (apply register-services
                        (if can-replace?
                            services
                            (remove registered? services))))))

(define* (start-service name #:optional (arguments '()))
  (invoke-action name 'start arguments
                 (lambda (result)
                   result)))

(define (stop-service name)
  (with-shepherd-action name ('stop) result
    result))

(define (restart-service name)
  (with-shepherd-action name ('restart) result
    result))

;; Local Variables:
;; eval: (put 'alist-let* 'scheme-indent-function 2)
;; eval: (put 'with-shepherd 'scheme-indent-function 1)
;; eval: (put 'with-shepherd-action 'scheme-indent-function 3)
;; End:

;;; herd.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; 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 hurd)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages hurd)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:export (hurd-console-configuration
            hurd-console-service-type
            hurd-getty-configuration
            hurd-getty-service-type))

;;; Commentary:
;;;
;;; This module implements services for the Hurd.
;;;
;;; Code:

;;;
;;; The Hurd VGA console service.
;;;

(define-record-type* <hurd-console-configuration>
  hurd-console-configuration make-hurd-console-configuration
  hurd-console-configuration?
  (hurd   hurd-console-configuration-hurd ;package
          (default hurd)))

(define (hurd-console-shepherd-service config)
  "Return a <shepherd-service> for a Hurd VGA console with CONFIG."

  (define console-command
    #~(list
       (string-append #$(hurd-console-configuration-hurd config) "/bin/console")
       "-c" "/dev/vcs"
       "-d" "vga"
       "-d" "pc_kbd"
       "-d" "generic_speaker"))

  (list (shepherd-service
         (documentation "Run the Hurd’s VGA console client.")
         (provision '(console))
         (requirement '(user-processes))
         (start #~(make-forkexec-constructor #$console-command))
         (stop #~(make-kill-destructor)))))

(define hurd-console-service-type
  (service-type
   (name 'console)
   (description "Run the Hurd console client.")
   (extensions
    (list (service-extension shepherd-root-service-type
                             hurd-console-shepherd-service)))
   (default-value (hurd-console-configuration))))

;;;
;;; The Hurd getty service.
;;;

(define-record-type* <hurd-getty-configuration>
  hurd-getty-configuration make-hurd-getty-configuration
  hurd-getty-configuration?
  (hurd       hurd-getty-configuration-hurd  ;<package>
              (default hurd))
  (tty        hurd-getty-configuration-tty)  ;string
  (baud-rate  hurd-getty-configuration-baud-rate
              (default 38400)))              ;integer

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

  (let ((hurd      (hurd-getty-configuration-hurd config))
        (tty       (hurd-getty-configuration-tty config))
        (baud-rate (hurd-getty-configuration-baud-rate config)))

    (define getty-command
      #~(list
         (string-append #$hurd "/libexec/getty")
         #$(number->string baud-rate)
         #$tty))

    (list
     (shepherd-service
      (documentation "Run getty on a tty.")
      (provision (list (string->symbol (string-append "term-" tty))))
      (requirement '(user-processes console))
      (start #~(make-forkexec-constructor #$getty-command))
      (stop  #~(make-kill-destructor))))))

(define hurd-getty-service-type
  (service-type
   (name 'getty)
   (extensions (list (service-extension shepherd-root-service-type
                                        hurd-getty-shepherd-service)))
   (description
    "Provide console login using the Hurd @command{getty} program.")))

;;; hurd.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 John Darrington <jmd@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 kerberos)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu system pam)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (pam-krb5-configuration
            pam-krb5-configuration?
            pam-krb5-service-type

            krb5-realm
            krb5-realm?

            krb5-configuration
            krb5-configuration?
            krb5-service-type))

(define unset-field (list 'unset-field))

(define (predicate/unset pred)
  (lambda (x) (or (eq? x unset-field) (pred x))))

(define string/unset? (predicate/unset string?))
(define boolean/unset? (predicate/unset boolean?))
(define integer/unset? (predicate/unset integer?))

(define (uglify-field-name field-name)
  "Return FIELD-NAME with all instances of '-' replaced by '_' and any
trailing '?' removed."
  (let ((str (symbol->string field-name)))
    (string-join (string-split (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-string/unset field-name val)
  (unless (eq? val unset-field)
      (serialize-field* field-name val)))

(define (serialize-integer/unset field-name val)
  (unless (eq? val unset-field)
      (serialize-field* field-name val)))

(define (serialize-boolean/unset field-name val)
  (unless (eq? val unset-field)
      (serialize-field* field-name
                        (if val "true" "false"))))

;; An end-point is an address such as "192.168.0.1"
;; or an address port pair ("foobar.example.com" . 109)
(define (end-point? val)
  (match val
    ((? string?) #t)
    (((? string?) . (? integer?)) #t)
    (_ #f)))

(define (serialize-end-point field-name val)
  (serialize-field* field-name
                    (match val
                      ((host . port)
                       ;; The [] are needed in the case of IPv6 addresses
                       (format #f "[~a]:~a" host port))
                      (host
                       (format #f "~a" host)))))

(define (serialize-space-separated-string-list/unset field-name val)
  (unless (eq? val unset-field)
      (serialize-field* field-name (string-join val " "))))

(define (space-separated-string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (and (string? x) (not (string-index x #\space))))
                val)))

(define space-separated-string-list/unset?
  (predicate/unset space-separated-string-list?))

(define comma-separated-integer-list/unset?
  (predicate/unset (lambda (val)
                     (and (list? val)
                          (and-map (lambda (x) (integer? x))
                                   val)))))

(define (serialize-comma-separated-integer-list/unset field-name val)
  (unless (eq? val unset-field)
      (serialize-field* field-name
                       (string-drop ; Drop the leading comma
                        (fold
                         (lambda (i prev)
                           (string-append prev "," (number->string i)))
                         "" val) 1))))

(define file-name? (predicate/unset
                    (lambda (val)
                      (string-prefix? "/" val))))

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

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

(define (serialize-file-name field-name val)
  (unless (eq? val unset-field)
    (serialize-string field-name val)))

(define (serialize-space-separated-string-list field-name val)
  (serialize-field field-name (string-join val " ")))

(define (non-negative-integer? val)
  (and (exact-integer? val) (not (negative? val))))

(define (serialize-non-negative-integer/unset field-name val)
  (unless (eq? val unset-field)
    (serialize-field* field-name val)))

(define (free-form-fields? val)
  (match val
    (() #t)
    ((((? symbol?) . (? string)) . val) (free-form-fields? val))
    (_ #f)))

(define (serialize-free-form-fields field-name val)
  (for-each (match-lambda ((k . v) (serialize-field* k v))) val))

(define non-negative-integer/unset? (predicate/unset non-negative-integer?))

(define (realm-list? val)
  (and (list? val)
       (and-map (lambda (x) (krb5-realm? x)) val)))

(define (serialize-realm-list field-name val)
  (format #t "\n[~a]\n" field-name)
  (for-each (lambda (realm)
              (format #t "\n~a = {\n" (krb5-realm-name realm))
              (for-each (lambda (field)
                          (unless (eq? 'name (configuration-field-name field))
                            ((configuration-field-serializer field)
                             (configuration-field-name field)
                             ((configuration-field-getter field)
                              realm)))) krb5-realm-fields)

              (format #t "}\n")) val))

;; For a more detailed explanation of these fields see man 5 krb5.conf
(define-configuration krb5-realm
  (name
   (string/unset unset-field)
   "The name of the realm.")

  (kdc
   (end-point unset-field)
   "The host and port on which the realm's Key Distribution Server listens.")

  (admin-server
   (string/unset unset-field)
   "The Host running the administration server for the realm.")

  (master-kdc
   (string/unset unset-field)
   "If an attempt to get credentials fails because of an invalid password,
the client software will attempt to contact the master KDC.")

  (kpasswd-server
   (string/unset unset-field)
   "The server where password changes are performed.")

  (auth-to-local
   (free-form-fields '())
   "Rules to map between principals and local users.")

  (auth-to-local-names
   (free-form-fields '())
   "Explicit mappings between principal names and local user names.")

  (http-anchors
   (free-form-fields '())
   "Useful only when http proxy is used to access KDC or KPASSWD.")

  ;; The following are useful only for working with V4 services
  (default-domain
    (string/unset unset-field)
    "The domain used to expand host names when translating Kerberos 4 service
principals to Kerberos 5 principals")

  (v4-instance-convert
   (free-form-fields '())
   "Exceptions to the default-domain mapping rule.")

  (v4-realm
   (string/unset unset-field)
   "Used  when the V4 realm name and the V5 realm name are not the same, but
still share the same principal names and passwords"))

;; For a more detailed explanation of these fields see man 5 krb5.conf
(define-configuration krb5-configuration
  (allow-weak-crypto?
   (boolean/unset unset-field)
   "If true, permits access to services which only offer weak encryption.")

  (ap-req-checksum-type
   (non-negative-integer/unset unset-field)
   "The type of the AP-REQ checksum.")

  (canonicalize?
   (boolean/unset unset-field)
   "Should principals in initial ticket requests be canonicalized?")

  (ccache-type
   (non-negative-integer/unset unset-field)
   "The format of the credential cache type.")

  (clockskew
   (non-negative-integer/unset unset-field)
   "Maximum allowable clock skew in seconds (default 300).")

  (default-ccache-name
    (file-name unset-field)
    "The name of the default credential cache.")

  (default-client-keytab-name
    (file-name unset-field)
    "The name of the default keytab for client credentials.")

  (default-keytab-name
    (file-name unset-field)
    "The name of the default keytab file.")

  (default-realm
    (string/unset unset-field)
    "The realm to be accessed if not explicitly specified by clients.")

  (default-tgs-enctypes
    (free-form-fields '())
    "Session key encryption types when making TGS-REQ requests.")

  (default-tkt-enctypes
    (free-form-fields '())
    "Session key encryption types when making AS-REQ requests.")

  (dns-canonicalize-hostname?
   (boolean/unset  unset-field)
   "Whether name lookups will be used to canonicalize host names for use in
service principal names.")

  (dns-lookup-kdc?
   (boolean/unset unset-field)
 "Should DNS SRV records should be used to locate the KDCs and other servers
not appearing in the realm specification")

  (err-fmt
   (string/unset unset-field)
   "Custom error message formatting. If not #f error messages will be formatted
by substituting a normal error message for %M and an error code for %C in the
value.")

  (forwardable?
   (boolean/unset unset-field)
   "Should initial tickets be forwardable by default?")

  (ignore-acceptor-hostname?
   (boolean/unset unset-field)
   "When accepting GSSAPI or krb5 security contexts for host-based service
principals, ignore any hostname passed by the calling application, and allow
clients to authenticate to any service principal in the keytab matching the
service name and realm name.")

  (k5login-authoritative?
   (boolean/unset unset-field)
   "If this flag is true, principals must be listed in a local user's k5login
file to be granted login access, if a ~/.k5login file exists.")

  (k5login-directory
   (string/unset unset-field)
   "If not #f, the library will look for a local user's @file{k5login} file
within the named directory (instead of the user's home directory), with a
file name corresponding to the local user name.")

  (kcm-mach-service
   (string/unset unset-field)
   "The name of the bootstrap service used to contact the KCM daemon for the
KCM credential cache type.")

  (kcm-socket
   (file-name unset-field)
 "Path to the Unix domain socket used to access the KCM daemon for the KCM
credential cache type.")

  (kdc-default-options
   (non-negative-integer/unset unset-field)
   "Default KDC options (logored for multiple values) when requesting initial
tickets.")

  (kdc-timesync
   (non-negative-integer/unset unset-field)
   "Attempt to compensate for clock skew between the KDC and client.")

  (kdc-req-checksum-type
   (non-negative-integer/unset unset-field)
   "The type of checksum to use for the KDC requests. Relevant only for DES
keys")

  (noaddresses?
   (boolean/unset unset-field)
   "If true, initial ticket requests will not be made with address restrictions.
This enables their use across NATs.")

  (permitted-enctypes
   (space-separated-string-list/unset unset-field)
   "All encryption types that are permitted for use in session key encryption.")

  (plugin-base-dir
   (file-name unset-field)
   "The directory where krb5 plugins are located.")

  (preferred-preauth-types
   (comma-separated-integer-list/unset unset-field)
   "The preferred pre-authentication types which the client will attempt before
others.")

  (proxiable?
   (boolean/unset unset-field)
   "Should initial tickets be proxiable by default?")

  (rdns?
   (boolean/unset unset-field)
   "Should reverse DNS lookup be used in addition to forward name lookup to
canonicalize host names for use in service principal names.")

  (realm-try-domains
   (integer/unset unset-field)
   "Should a host's domain components should be used to determine the Kerberos
realm of the host.")

  (renew-lifetime
   (non-negative-integer/unset unset-field)
   "The default renewable lifetime for initial ticket requests.")

  (safe-checksum-type
   (non-negative-integer/unset unset-field)
   "The type of checksum to use for the KRB-SAFE requests.")

  (ticket-lifetime
   (non-negative-integer/unset unset-field)
   "The default lifetime for initial ticket requests.")

  (udp-preference-limit
   (non-negative-integer/unset unset-field)
   "When sending messages to the KDC, the library will try using TCP
before UDP if the size of the message greater than this limit.")

  (verify-ap-rereq-nofail?
   (boolean/unset unset-field)
 "If true, then attempts to verify initial credentials will fail if the client
machine does not have a keytab.")

  (realms
   (realm-list '())
   "The list of realms which clients may access."))

(define (krb5-configuration-file config)
  "Create a Kerberos 5 configuration file based on CONFIG"
  (mixed-text-file "krb5.conf"
                   "[libdefaults]\n\n"
                   (with-output-to-string
                     (lambda ()
                       (serialize-configuration config
                                                krb5-configuration-fields)))))

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

(define krb5-service-type
  (service-type (name 'krb5)
                (extensions
                 (list (service-extension etc-service-type
                                          krb5-etc-service)))))

(define-record-type* <pam-krb5-configuration>
  pam-krb5-configuration  make-pam-krb5-configuration
  pam-krb5-configuration?
  (pam-krb5               pam-krb5-configuration-pam-krb5
                          (default pam-krb5))
  (minimum-uid            pam-krb5-configuration-minimum-uid
                          (default 1000)))

(define (pam-krb5-pam-service config)
  "Return a PAM service for Kerberos authentication."
  (lambda (pam)
    (define pam-krb5-module
      #~(string-append #$(pam-krb5-configuration-pam-krb5 config)
                       "/lib/security/pam_krb5.so"))

    (let ((pam-krb5-sufficient
           (pam-entry
            (control "sufficient")
            (module pam-krb5-module)
            (arguments
             (list
              (format #f "minimum_uid=~a"
                      (pam-krb5-configuration-minimum-uid config)))))))
      (pam-service
       (inherit pam)
       (auth (cons* pam-krb5-sufficient
                    (pam-service-auth pam)))
       (session (cons* pam-krb5-sufficient
                       (pam-service-session pam)))
       (account (cons* pam-krb5-sufficient
                       (pam-service-account pam)))))))

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

(define pam-krb5-service-type
  (service-type (name 'pam-krb5)
                (extensions
                 (list
                  (service-extension pam-root-service-type
                                     pam-krb5-pam-services)))))