code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services dns)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages dns)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (knot-service-type
            knot-acl-configuration
            knot-key-configuration
            knot-keystore-configuration
            knot-zone-configuration
            knot-remote-configuration
            knot-policy-configuration
            knot-configuration
            define-zone-entries
            zone-file
            zone-entry

            knot-resolver-service-type
            knot-resolver-configuration

            dnsmasq-service-type
            dnsmasq-configuration

            ddclient-service-type
            ddclient-configuration))

;;;
;;; Knot DNS.
;;;

(define-record-type* <knot-key-configuration>
  knot-key-configuration make-knot-key-configuration
  knot-key-configuration?
  (id        knot-key-configuration-id
             (default ""))
  (algorithm knot-key-configuration-algorithm
             (default #f)); one of #f, or an algorithm name
  (secret    knot-key-configuration-secret
             (default "")))

(define-record-type* <knot-acl-configuration>
  knot-acl-configuration make-knot-acl-configuration
  knot-acl-configuration?
  (id      knot-acl-configuration-id
           (default ""))
  (address knot-acl-configuration-address
           (default '()))
  (key     knot-acl-configuration-key
           (default '()))
  (action  knot-acl-configuration-action
           (default '()))
  (deny?   knot-acl-configuration-deny?
           (default #f)))

(define-record-type* <zone-entry>
  zone-entry make-zone-entry
  zone-entry?
  (name  zone-entry-name
         (default "@"))
  (ttl   zone-entry-ttl
         (default ""))
  (class zone-entry-class
         (default "IN"))
  (type  zone-entry-type
         (default "A"))
  (data  zone-entry-data
         (default "")))

(define-record-type* <zone-file>
  zone-file make-zone-file
  zone-file?
  (entries zone-file-entries
           (default '()))
  (origin  zone-file-origin
           (default ""))
  (ns      zone-file-ns
           (default "ns"))
  (mail    zone-file-mail
           (default "hostmaster"))
  (serial  zone-file-serial
           (default 1))
  (refresh zone-file-refresh
           (default (* 2 24 3600)))
  (retry   zone-file-retry
           (default (* 15 60)))
  (expiry  zone-file-expiry
           (default (* 2 7 24 3600)))
  (nx      zone-file-nx
           (default 3600)))
(define-record-type* <knot-keystore-configuration>
  knot-keystore-configuration make-knot-keystore-configuration
  knot-keystore-configuration?
  (id knot-keystore-configuration-id
      (default ""))
  (backend knot-keystore-configuration-backend
           (default 'pem))
  (config  knot-keystore-configuration-config
           (default "/var/lib/knot/keys/keys")))

(define-record-type* <knot-policy-configuration>
  knot-policy-configuration make-knot-policy-configuration
  knot-policy-configuration?
  (id                   knot-policy-configuration-id
                        (default ""))
  (keystore             knot-policy-configuration-keystore
                        (default "default"))
  (manual?              knot-policy-configuration-manual?
                        (default #f))
  (single-type-signing? knot-policy-configuration-single-type-signing?
                        (default #f))
  (algorithm            knot-policy-configuration-algorithm
                        (default "ecdsap256sha256"))
  (ksk-size             knot-policy-configuration-ksk-size
                        (default 256))
  (zsk-size             knot-policy-configuration-zsk-size
                        (default 256))
  (dnskey-ttl           knot-policy-configuration-dnskey-ttl
                        (default 'default))
  (zsk-lifetime         knot-policy-configuration-zsk-lifetime
                        (default (* 30 24 3600)))
  (propagation-delay    knot-policy-configuration-propagation-delay
                        (default (* 24 3600)))
  (rrsig-lifetime       knot-policy-configuration-rrsig-lifetime
                        (default (* 14 24 3600)))
  (rrsig-refresh        knot-policy-configuration-rrsig-refresh
                        (default (* 7 24 3600)))
  (nsec3?               knot-policy-configuration-nsec3?
                        (default #f))
  (nsec3-iterations     knot-policy-configuration-nsec3-iterations
                        (default 5))
  (nsec3-salt-length    knot-policy-configuration-nsec3-salt-length
                        (default 8))
  (nsec3-salt-lifetime  knot-policy-configuration-nsec3-salt-lifetime
                        (default (* 30 24 3600))))

(define-record-type* <knot-zone-configuration>
  knot-zone-configuration make-knot-zone-configuration
  knot-zone-configuration?
  (domain            knot-zone-configuration-domain
                     (default ""))
  (file              knot-zone-configuration-file
                     (default "")) ; the file where this zone is saved.
  (zone              knot-zone-configuration-zone
                     (default (zone-file))) ; initial content of the zone file
  (master            knot-zone-configuration-master
                     (default '()))
  (ddns-master       knot-zone-configuration-ddns-master
                     (default #f))
  (notify            knot-zone-configuration-notify
                     (default '()))
  (acl               knot-zone-configuration-acl
                     (default '()))
  (semantic-checks?  knot-zone-configuration-semantic-checks?
                     (default #f))
  (disable-any?      knot-zone-configuration-disable-any?
                     (default #f))
  (zonefile-sync     knot-zone-configuration-zonefile-sync
                     (default 0))
  (zonefile-load     knot-zone-configuration-zonefile-load
                     (default #f))
  (journal-content   knot-zone-configuration-journal-content
                     (default #f))
  (max-journal-usage knot-zone-configuration-max-journal-usage
                     (default #f))
  (max-journal-depth knot-zone-configuration-max-journal-depth
                     (default #f))
  (max-zone-size     knot-zone-configuration-max-zone-size
                     (default #f))
  (dnssec-policy     knot-zone-configuration-dnssec-policy
                     (default #f))
  (serial-policy     knot-zone-configuration-serial-policy
                     (default 'increment)))

(define-record-type* <knot-remote-configuration>
  knot-remote-configuration make-knot-remote-configuration
  knot-remote-configuration?
  (id  knot-remote-configuration-id
       (default ""))
  (address knot-remote-configuration-address
           (default '()))
  (via     knot-remote-configuration-via
           (default '()))
  (key     knot-remote-configuration-key
           (default #f)))

(define-record-type* <knot-configuration>
  knot-configuration make-knot-configuration
  knot-configuration?
  (knot          knot-configuration-knot
                 (default knot))
  (run-directory knot-configuration-run-directory
                 (default "/var/run/knot"))
  (includes      knot-configuration-includes
                 (default '()))
  (listen-v4     knot-configuration-listen-v4
                 (default "0.0.0.0"))
  (listen-v6     knot-configuration-listen-v6
                 (default "::"))
  (listen-port   knot-configuration-listen-port
                 (default 53))
  (keys          knot-configuration-keys
                 (default '()))
  (keystores     knot-configuration-keystores
                 (default '()))
  (acls          knot-configuration-acls
                 (default '()))
  (remotes       knot-configuration-remotes
                 (default '()))
  (policies      knot-configuration-policies
                 (default '()))
  (zones         knot-configuration-zones
                 (default '())))

(define-syntax define-zone-entries
  (syntax-rules ()
    ((_ id (name ttl class type data) ...)
     (define id (list (make-zone-entry name ttl class type data) ...)))))

(define (error-out msg)
  (raise (condition (&message (message msg)))))

(define (verify-knot-key-configuration key)
  (unless (knot-key-configuration? key)
    (error-out "keys must be a list of only knot-key-configuration."))
  (let ((id (knot-key-configuration-id key)))
    (unless (and (string? id) (not (equal? id "")))
      (error-out "key id must be a non empty string.")))
  (unless (memq (knot-key-configuration-algorithm key)
                '(#f hmac-md5 hmac-sha1 hmac-sha224 hmac-sha256 hmac-sha384 hmac-sha512))
    (error-out "algorithm must be one of: #f, 'hmac-md5, 'hmac-sha1,
'hmac-sha224, 'hmac-sha256, 'hmac-sha384 or 'hmac-sha512")))

(define (verify-knot-keystore-configuration keystore)
  (unless (knot-keystore-configuration? keystore)
    (error-out "keystores must be a list of only knot-keystore-configuration."))
  (let ((id (knot-keystore-configuration-id keystore)))
    (unless (and (string? id) (not (equal? id "")))
      (error-out "keystore id must be a non empty string.")))
  (unless (memq (knot-keystore-configuration-backend keystore)
                '(pem pkcs11))
    (error-out "backend must be one of: 'pem or 'pkcs11")))

(define (verify-knot-policy-configuration policy)
  (unless (knot-policy-configuration? policy)
    (error-out "policies must be a list of only knot-policy-configuration."))
  (let ((id (knot-policy-configuration-id policy)))
    (unless (and (string? id) (not (equal? id "")))
      (error-out "policy id must be a non empty string."))))

(define (verify-knot-acl-configuration acl)
  (unless (knot-acl-configuration? acl)
    (error-out "acls must be a list of only knot-acl-configuration."))
  (let ((id (knot-acl-configuration-id acl))
        (address (knot-acl-configuration-address acl))
        (key (knot-acl-configuration-key acl))
        (action (knot-acl-configuration-action acl)))
    (unless (and (string? id) (not (equal? id "")))
      (error-out "acl id must be a non empty string."))
    (unless (and (list? address)
                 (every string? address))
      (error-out "acl address must be a list of strings.")))
  (unless (boolean? (knot-acl-configuration-deny? acl))
    (error-out "deny? must be #t or #f.")))

(define (verify-knot-zone-configuration zone)
  (unless (knot-zone-configuration? zone)
    (error-out "zones must be a list of only knot-zone-configuration."))
  (let ((domain (knot-zone-configuration-domain zone)))
    (unless (and (string? domain) (not (equal? domain "")))
      (error-out "zone domain must be a non empty string."))))

(define (verify-knot-remote-configuration remote)
  (unless (knot-remote-configuration? remote)
    (error-out "remotes must be a list of only knot-remote-configuration."))
  (let ((id (knot-remote-configuration-id remote)))
    (unless (and (string? id) (not (equal? id "")))
      (error-out "remote id must be a non empty string."))))

(define (verify-knot-configuration config)
  (unless (package? (knot-configuration-knot config))
    (error-out "knot configuration field must be a package."))
  (unless (string? (knot-configuration-run-directory config))
    (error-out "run-directory must be a string."))
  (unless (list? (knot-configuration-includes config))
    (error-out "includes must be a list of strings or file-like objects."))
  (unless (list? (knot-configuration-keys config))
    (error-out "keys must be a list of knot-key-configuration."))
  (for-each (lambda (key) (verify-knot-key-configuration key))
            (knot-configuration-keys config))
  (unless (list? (knot-configuration-keystores config))
    (error-out "keystores must be a list of knot-keystore-configuration."))
  (for-each (lambda (keystore) (verify-knot-keystore-configuration keystore))
            (knot-configuration-keystores config))
  (unless (list? (knot-configuration-acls config))
    (error-out "acls must be a list of knot-acl-configuration."))
  (for-each (lambda (acl) (verify-knot-acl-configuration acl))
            (knot-configuration-acls config))
  (unless (list? (knot-configuration-zones config))
    (error-out "zones must be a list of knot-zone-configuration."))
  (for-each (lambda (zone) (verify-knot-zone-configuration zone))
            (knot-configuration-zones config))
  (unless (list? (knot-configuration-policies config))
    (error-out "policies must be a list of knot-policy-configuration."))
  (for-each (lambda (policy) (verify-knot-policy-configuration policy))
            (knot-configuration-policies config))
  (unless (list? (knot-configuration-remotes config))
    (error-out "remotes must be a list of knot-remote-configuration."))
  (for-each (lambda (remote) (verify-knot-remote-configuration remote))
            (knot-configuration-remotes config))
  #t)

(define (format-string-list l)
  "Formats a list of string in YAML"
  (if (eq? l '())
      ""
      (let ((l (reverse l)))
        (string-append
          "["
          (fold (lambda (x1 x2)
                  (string-append (if (symbol? x1) (symbol->string x1) x1) ", "
                                 (if (symbol? x2) (symbol->string x2) x2)))
                (if (symbol? (car l)) (symbol->string (car l)) (car l)) (cdr l))
          "]"))))

(define (knot-acl-config acls)
  (with-output-to-string
    (lambda ()
      (for-each
        (lambda (acl-config)
          (let ((id (knot-acl-configuration-id acl-config))
                (address (knot-acl-configuration-address acl-config))
                (key (knot-acl-configuration-key acl-config))
                (action (knot-acl-configuration-action acl-config))
                (deny? (knot-acl-configuration-deny? acl-config)))
            (format #t "    - id: ~a\n" id)
            (unless (eq? address '())
              (format #t "      address: ~a\n" (format-string-list address)))
            (unless (eq? key '())
              (format #t "      key: ~a\n" (format-string-list key)))
            (unless (eq? action '())
              (format #t "      action: ~a\n" (format-string-list action)))
            (format #t "      deny: ~a\n" (if deny? "on" "off"))))
        acls))))

(define (knot-key-config keys)
  (with-output-to-string
    (lambda ()
      (for-each
        (lambda (key-config)
          (let ((id (knot-key-configuration-id key-config))
                (algorithm (knot-key-configuration-algorithm key-config))
                (secret (knot-key-configuration-secret key-config)))
            (format #t     "    - id: ~a\n" id)
            (if algorithm
                (format #t "      algorithm: ~a\n" (symbol->string algorithm)))
            (format #t     "      secret: ~a\n" secret)))
        keys))))

(define (knot-keystore-config keystores)
  (with-output-to-string
    (lambda ()
      (for-each
        (lambda (keystore-config)
          (let ((id (knot-keystore-configuration-id keystore-config))
                (backend (knot-keystore-configuration-backend keystore-config))
                (config (knot-keystore-configuration-config keystore-config)))
            (format #t "    - id: ~a\n" id)
            (format #t "      backend: ~a\n" (symbol->string backend))
            (format #t "      config: \"~a\"\n" config)))
        keystores))))

(define (knot-policy-config policies)
  (with-output-to-string
    (lambda ()
      (for-each
        (lambda (policy-config)
          (let ((id (knot-policy-configuration-id policy-config))
                (keystore (knot-policy-configuration-keystore policy-config))
                (manual? (knot-policy-configuration-manual? policy-config))
                (single-type-signing? (knot-policy-configuration-single-type-signing?
                                        policy-config))
                (algorithm (knot-policy-configuration-algorithm policy-config))
                (ksk-size (knot-policy-configuration-ksk-size policy-config))
                (zsk-size (knot-policy-configuration-zsk-size policy-config))
                (dnskey-ttl (knot-policy-configuration-dnskey-ttl policy-config))
                (zsk-lifetime (knot-policy-configuration-zsk-lifetime policy-config))
                (propagation-delay (knot-policy-configuration-propagation-delay
                                     policy-config))
                (rrsig-lifetime (knot-policy-configuration-rrsig-lifetime
                                  policy-config))
                (nsec3? (knot-policy-configuration-nsec3? policy-config))
                (nsec3-iterations (knot-policy-configuration-nsec3-iterations
                                    policy-config))
                (nsec3-salt-length (knot-policy-configuration-nsec3-salt-length
                                     policy-config))
                (nsec3-salt-lifetime (knot-policy-configuration-nsec3-salt-lifetime
                                       policy-config)))
            (format #t "    - id: ~a\n" id)
            (format #t "      keystore: ~a\n" keystore)
            (format #t "      manual: ~a\n" (if manual? "on" "off"))
            (format #t "      single-type-signing: ~a\n" (if single-type-signing?
                                                             "on" "off"))
            (format #t "      algorithm: ~a\n" algorithm)
            (format #t "      ksk-size: ~a\n" (number->string ksk-size))
            (format #t "      zsk-size: ~a\n" (number->string zsk-size))
            (unless (eq? dnskey-ttl 'default)
              (format #t "      dnskey-ttl: ~a\n" dnskey-ttl))
            (format #t "      zsk-lifetime: ~a\n" zsk-lifetime)
            (format #t "      propagation-delay: ~a\n" propagation-delay)
            (format #t "      rrsig-lifetime: ~a\n" rrsig-lifetime)
            (format #t "      nsec3: ~a\n" (if nsec3? "on" "off"))
            (format #t "      nsec3-iterations: ~a\n"
                    (number->string nsec3-iterations))
            (format #t "      nsec3-salt-length: ~a\n"
                    (number->string nsec3-salt-length))
            (format #t "      nsec3-salt-lifetime: ~a\n" nsec3-salt-lifetime)))
        policies))))

(define (knot-remote-config remotes)
  (with-output-to-string
    (lambda ()
      (for-each
        (lambda (remote-config)
          (let ((id (knot-remote-configuration-id remote-config))
                (address (knot-remote-configuration-address remote-config))
                (via (knot-remote-configuration-via remote-config))
                (key (knot-remote-configuration-key remote-config)))
            (format #t "    - id: ~a\n" id)
            (unless (eq? address '())
              (format #t "      address: ~a\n" (format-string-list address)))
            (unless (eq? via '())
              (format #t "      via: ~a\n" (format-string-list via)))
            (if key
              (format #t "      key: ~a\n" key))))
        remotes))))

(define (serialize-zone-entries entries)
  (with-output-to-string
    (lambda ()
      (for-each
        (lambda (entry)
          (let ((name (zone-entry-name entry))
                (ttl (zone-entry-ttl entry))
                (class (zone-entry-class entry))
                (type (zone-entry-type entry))
                (data (zone-entry-data entry)))
            (format #t "~a ~a ~a ~a ~a\n" name ttl class type data)))
        entries))))

(define (serialize-zone-file zone domain)
  (computed-file (string-append domain ".zone")
    #~(begin
        (call-with-output-file #$output
          (lambda (port)
            (format port "$ORIGIN ~a.\n"
                    #$(zone-file-origin zone))
            (format port "@ IN SOA ~a ~a (~a ~a ~a ~a ~a)\n"
                    #$(zone-file-ns zone)
                    #$(zone-file-mail zone)
                    #$(zone-file-serial zone)
                    #$(zone-file-refresh zone)
                    #$(zone-file-retry zone)
                    #$(zone-file-expiry zone)
                    #$(zone-file-nx zone))
            (format port "~a\n"
                    #$(serialize-zone-entries (zone-file-entries zone))))))))

(define (knot-zone-config zone)
  (let ((content (knot-zone-configuration-zone zone)))
    #~(with-output-to-string
        (lambda ()
          (let ((domain #$(knot-zone-configuration-domain zone))
                (file #$(knot-zone-configuration-file zone))
                (master (list #$@(knot-zone-configuration-master zone)))
                (ddns-master #$(knot-zone-configuration-ddns-master zone))
                (notify (list #$@(knot-zone-configuration-notify zone)))
                (acl (list #$@(knot-zone-configuration-acl zone)))
                (semantic-checks? #$(knot-zone-configuration-semantic-checks? zone))
                (disable-any? #$(knot-zone-configuration-disable-any? zone))
                (zonefile-sync #$(knot-zone-configuration-zonefile-sync zone))
                (zonefile-load '#$(knot-zone-configuration-zonefile-load zone))
                (journal-content #$(knot-zone-configuration-journal-content zone))
                (max-journal-usage #$(knot-zone-configuration-max-journal-usage zone))
                (max-journal-depth #$(knot-zone-configuration-max-journal-depth zone))
                (max-zone-size #$(knot-zone-configuration-max-zone-size zone))
                (dnssec-policy #$(knot-zone-configuration-dnssec-policy zone))
                (serial-policy '#$(knot-zone-configuration-serial-policy zone)))
            (format #t "    - domain: ~a\n" domain)
            (if (eq? master '())
                ;; This server is a master
                (if (equal? file "")
                  (format #t "      file: ~a\n"
                    #$(serialize-zone-file content
                                           (knot-zone-configuration-domain zone)))
                  (format #t "      file: ~a\n" file))
                ;; This server is a slave (has masters)
                (begin
                  (format #t "      master: ~a\n"
                          #$(format-string-list
                              (knot-zone-configuration-master zone)))
                  (if ddns-master (format #t "      ddns-master ~a\n" ddns-master))))
            (unless (eq? notify '())
              (format #t "      notify: ~a\n"
                      #$(format-string-list
                          (knot-zone-configuration-notify zone))))
            (unless (eq? acl '())
              (format #t "      acl: ~a\n"
                      #$(format-string-list
                          (knot-zone-configuration-acl zone))))
            (format #t "      semantic-checks: ~a\n" (if semantic-checks? "on" "off"))
            (format #t "      disable-any: ~a\n" (if disable-any? "on" "off"))
            (if zonefile-sync
              (format #t "      zonefile-sync: ~a\n" zonefile-sync))
            (if zonefile-load
              (format #t "      zonefile-load: ~a\n"
                      (symbol->string zonefile-load)))
            (if journal-content
              (format #t "      journal-content: ~a\n"
                      (symbol->string journal-content)))
            (if max-journal-usage
              (format #t "      max-journal-usage: ~a\n" max-journal-usage))
            (if max-journal-depth
              (format #t "      max-journal-depth: ~a\n" max-journal-depth))
            (if max-zone-size
              (format #t "      max-zone-size: ~a\n" max-zone-size))
            (if dnssec-policy
                (begin
                  (format #t "      dnssec-signing: on\n")
                  (format #t "      dnssec-policy: ~a\n" dnssec-policy)))
            (format #t "      serial-policy: ~a\n"
                    (symbol->string serial-policy)))))))

(define (knot-config-file config)
  (verify-knot-configuration config)
  (computed-file "knot.conf"
    #~(begin
        (call-with-output-file #$output
          (lambda (port)
            (for-each (lambda (inc)
                        (format port "include: ~a\n" inc))
                      '#$(knot-configuration-includes config))
            (format port "server:\n")
            (format port "    rundir: ~a\n" #$(knot-configuration-run-directory config))
            (format port "    user: knot\n")
            (format port "    listen: ~a@~a\n"
                    #$(knot-configuration-listen-v4 config)
                    #$(knot-configuration-listen-port config))
            (format port "    listen: ~a@~a\n"
                    #$(knot-configuration-listen-v6 config)
                    #$(knot-configuration-listen-port config))
            (format port "\nkey:\n")
            (format port #$(knot-key-config (knot-configuration-keys config)))
            (format port "\nkeystore:\n")
            (format port #$(knot-keystore-config (knot-configuration-keystores config)))
            (format port "\nacl:\n")
            (format port #$(knot-acl-config (knot-configuration-acls config)))
            (format port "\nremote:\n")
            (format port #$(knot-remote-config (knot-configuration-remotes config)))
            (format port "\npolicy:\n")
            (format port #$(knot-policy-config (knot-configuration-policies config)))
            (unless #$(eq? (knot-configuration-zones config) '())
              (format port "\nzone:\n")
              (format port "~a\n"
                      (string-concatenate
                        (list #$@(map knot-zone-config
                                      (knot-configuration-zones config)))))))))))

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

(define (knot-activation config)
  (with-imported-modules (source-module-closure '((gnu build activation)))
    #~(begin
        (use-modules (gnu build activation))
        (mkdir-p/perms #$(knot-configuration-run-directory config)
                       (getpwnam "knot") #o755)
        (mkdir-p/perms "/var/lib/knot" (getpwnam "knot") #o755)
        (mkdir-p/perms "/var/lib/knot/keys" (getpwnam "knot") #o755)
        (mkdir-p/perms "/var/lib/knot/keys/keys" (getpwnam "knot") #o755))))

(define (knot-shepherd-service config)
  (let* ((config-file (knot-config-file config))
         (knot (knot-configuration-knot config)))
    (list (shepherd-service
            (documentation "Run the Knot DNS daemon.")
            (provision '(knot dns))
            (requirement '(networking))
            (start #~(make-forkexec-constructor
                       (list (string-append #$knot "/sbin/knotd")
                             "-c" #$config-file)))
            (stop #~(make-kill-destructor))))))

(define knot-service-type
  (service-type (name 'knot)
                (extensions
                  (list (service-extension shepherd-root-service-type
                                           knot-shepherd-service)
                        (service-extension activation-service-type
                                           knot-activation)
                        (service-extension account-service-type
                                           (const %knot-accounts))))
                (description
                 "Run @uref{https://www.knot-dns.cz/, Knot}, an authoritative
name server for the @acronym{DNS, Domain Name System}.")))

;;;
;;; Knot Resolver.
;;;

(define-record-type* <knot-resolver-configuration>
  knot-resolver-configuration
  make-knot-resolver-configuration
  knot-resolver-configuration?
  (package knot-resolver-configuration-package
           (default knot-resolver))
  (kresd-config-file knot-resolver-kresd-config-file
                     (default %kresd.conf))
  (garbage-collection-interval knot-resolver-garbage-collection-interval
                               (default 1000)))

(define %kresd.conf
  (plain-file "kresd.conf" "-- -*- mode: lua -*-
trust_anchors.add_file('/var/cache/knot-resolver/root.keys')
net = { '127.0.0.1', '::1' }
user('knot-resolver', 'knot-resolver')
modules = { 'hints > iterate', 'stats', 'predict' }
cache.size = 100 * MB
"))

(define %knot-resolver-accounts
  (list (user-group
         (name "knot-resolver")
         (system? #t))
        (user-account
         (name "knot-resolver")
         (group "knot-resolver")
         (system? #t)
         (home-directory "/var/cache/knot-resolver")
         (shell (file-append shadow "/sbin/nologin")))))

(define (knot-resolver-activation config)
  #~(begin
      (use-modules (guix build utils))
      (let ((rundir "/var/cache/knot-resolver")
            (owner (getpwnam "knot-resolver")))
        (mkdir-p rundir)
        (chown rundir (passwd:uid owner) (passwd:gid owner)))))

(define knot-resolver-shepherd-services
  (match-lambda
    (($ <knot-resolver-configuration> package
                                      kresd-config-file
                                      garbage-collection-interval)
     (list
      (shepherd-service
       (provision '(kresd))
       (requirement '(networking))
       (documentation "Run the Knot Resolver daemon.")
       (start #~(make-forkexec-constructor
                 '(#$(file-append package "/sbin/kresd")
                   "-c" #$kresd-config-file "-n"
                   "/var/cache/knot-resolver")))
       (stop #~(make-kill-destructor)))
      (shepherd-service
       (provision '(kres-cache-gc))
       (requirement '(user-processes))
       (documentation "Run the Knot Resolver Garbage Collector daemon.")
       (start #~(make-forkexec-constructor
                 '(#$(file-append package "/sbin/kres-cache-gc")
                   "-d" #$(number->string garbage-collection-interval)
                   "-c" "/var/cache/knot-resolver")
                 #:user "knot-resolver"
                 #:group "knot-resolver"))
       (stop #~(make-kill-destructor)))))))

(define knot-resolver-service-type
  (service-type
   (name 'knot-resolver)
   (extensions
    (list (service-extension shepherd-root-service-type
                             knot-resolver-shepherd-services)
          (service-extension activation-service-type
                             knot-resolver-activation)
          (service-extension account-service-type
                             (const %knot-resolver-accounts))))
   (default-value (knot-resolver-configuration))
   (description "Run the Knot DNS Resolver.")))

;;;
;;; Dnsmasq.
;;;

(define-record-type* <dnsmasq-configuration>
  dnsmasq-configuration make-dnsmasq-configuration
  dnsmasq-configuration?
  (package          dnsmasq-configuration-package
                    (default dnsmasq))  ;package
  (no-hosts?        dnsmasq-configuration-no-hosts?
                    (default #f))       ;boolean
  (port             dnsmasq-configuration-port
                    (default 53))       ;integer
  (local-service?   dnsmasq-configuration-local-service?
                    (default #t))       ;boolean
  (listen-addresses dnsmasq-configuration-listen-address
                    (default '()))      ;list of string
  (resolv-file      dnsmasq-configuration-resolv-file
                    (default "/etc/resolv.conf")) ;string
  (no-resolv?       dnsmasq-configuration-no-resolv?
                    (default #f))       ;boolean
  (servers          dnsmasq-configuration-servers
                    (default '()))      ;list of string
  (addresses        dnsmasq-configuration-addresses
                    (default '()))      ;list of string
  (cache-size       dnsmasq-configuration-cache-size
                    (default 150))      ;integer
  (negative-cache?  dnsmasq-configuration-negative-cache?
                    (default #t))      ;boolean
  (tftp-enable?     dnsmasq-configuration-tftp-enable?
                    (default #f))       ;boolean
  (tftp-no-fail?    dnsmasq-configuration-tftp-no-fail?
                    (default #f))       ;boolean
  (tftp-single-port? dnsmasq-configuration-tftp-single-port?
                    (default #f))       ;boolean
  (tftp-secure?     dnsmasq-tftp-secure?
                    (default #f))       ;boolean
  (tftp-max         dnsmasq-tftp-max
                    (default #f))       ;integer
  (tftp-mtu         dnsmasq-tftp-mtu
                    (default #f))       ;integer
  (tftp-no-blocksize? dnsmasq-tftp-no-blocksize?
                      (default #f))     ;boolean
  (tftp-lowercase?  dnsmasq-tftp-lowercase?
                    (default #f))       ;boolean
  (tftp-port-range  dnsmasq-tftp-port-range
                    (default #f))       ;string
  (tftp-root        dnsmasq-tftp-root
                    (default "/var/empty,lo")) ;string
  (tftp-unique-root dnsmasq-tftp-unique-root
                    (default #f)))      ;"" or "ip" or "mac"

(define dnsmasq-shepherd-service
  (match-lambda
    (($ <dnsmasq-configuration> package
                                no-hosts?
                                port local-service? listen-addresses
                                resolv-file no-resolv? servers
                                addresses cache-size negative-cache?
                                tftp-enable? tftp-no-fail?
                                tftp-single-port? tftp-secure?
                                tftp-max tftp-mtu tftp-no-blocksize?
                                tftp-lowercase? tftp-port-range
                                tftp-root tftp-unique-root)
     (shepherd-service
      (provision '(dnsmasq))
      (requirement '(networking))
      (documentation "Run the dnsmasq DNS server.")
      (start #~(make-forkexec-constructor
                '(#$(file-append package "/sbin/dnsmasq")
                  "--keep-in-foreground"
                  "--pid-file=/run/dnsmasq.pid"
                  #$@(if no-hosts?
                         '("--no-hosts")
                         '())
                  #$(format #f "--port=~a" port)
                  #$@(if local-service?
                         '("--local-service")
                         '())
                  #$@(map (cut format #f "--listen-address=~a" <>)
                          listen-addresses)
                  #$(format #f "--resolv-file=~a" resolv-file)
                  #$@(if no-resolv?
                         '("--no-resolv")
                         '())
                  #$@(map (cut format #f "--server=~a" <>)
                          servers)
                  #$@(map (cut format #f "--address=~a" <>)
                          addresses)
                  #$(format #f "--cache-size=~a" cache-size)
                  #$@(if negative-cache?
                         '()
                         '("--no-negcache"))
                  #$@(if tftp-enable?
                         '("--enable-tftp")
                         '())
                  #$@(if tftp-no-fail?
                         '("--tftp-no-fail")
                         '())
                  #$@(if tftp-single-port?
                         '("--tftp-single-port")
                         '())
                  #$@(if tftp-secure?
                         '("--tftp-secure?")
                         '())
                  #$@(if tftp-max
                         (list (format #f "--tftp-max=~a" tftp-max))
                         '())
                  #$@(if tftp-mtu
                         (list (format #f "--tftp-mtu=~a" tftp-mtu))
                         '())
                  #$@(if tftp-no-blocksize?
                         '("--tftp-no-blocksize")
                         '())
                  #$@(if tftp-lowercase?
                         '("--tftp-lowercase")
                         '())
                  #$@(if tftp-port-range
                         (list (format #f "--tftp-port-range=~a"
                                          tftp-port-range))
                         '())
                  #$@(if tftp-root
                         (list (format #f "--tftp-root=~a" tftp-root))
                         '())
                  #$@(if tftp-unique-root
                         (list
                          (if (> (length tftp-unique-root) 0)
                              (format #f "--tftp-unique-root=~a" tftp-unique-root)
                              (format #f "--tftp-unique-root")))
                         '()))
                #:pid-file "/run/dnsmasq.pid"))
      (stop #~(make-kill-destructor))))))

(define (dnsmasq-activation config)
  #~(begin
      (use-modules (guix build utils))
      ;; create directory to store dnsmasq lease file
      (mkdir-p "/var/lib/misc")))

(define dnsmasq-service-type
  (service-type
   (name 'dnsmasq)
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list dnsmasq-shepherd-service))
          (service-extension activation-service-type
                             dnsmasq-activation)))
   (default-value (dnsmasq-configuration))
   (description "Run the dnsmasq DNS server.")))

;;;
;;; ddclient
;;;

(define (uglify-field-name field-name)
  (string-delete #\? (symbol->string field-name)))

(define (serialize-field field-name val)
  (when (not (member field-name '(group secret-file user)))
    (format #t "~a=~a\n" (uglify-field-name field-name) val)))

(define (serialize-boolean field-name val)
  (serialize-field field-name (if val "yes" "no")))

(define (serialize-integer field-name val)
  (serialize-field field-name (number->string val)))

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

(define (serialize-list field-name val)
  (if (null? val) "" (serialize-field field-name (string-join val))))

(define (serialize-extra-options extra-options)
  (string-join extra-options "\n" 'suffix))

(define-configuration ddclient-configuration
  (ddclient
   (package ddclient)
   "The ddclient package.")
  (daemon
   (integer 300)
   "The period after which ddclient will retry to check IP and domain name.")
  (syslog
   (boolean #t)
   "Use syslog for the output.")
  (mail
   (string "root")
   "Mail to user.")
  (mail-failure
   (string "root")
   "Mail failed update to user.")
  (pid
   (string "/var/run/ddclient/ddclient.pid")
   "The ddclient PID file.")
  (ssl
   (boolean #t)
   "Enable SSL support.")
  (user
   (string "ddclient")
   "Specifies the user name or ID that is used when running ddclient
program.")
  (group
   (string "ddclient")
   "Group of the user who will run the ddclient program.")
  (secret-file
   (string "/etc/ddclient/secrets.conf")
   "Secret file which will be appended to @file{ddclient.conf} file.  This
file contains credentials for use by ddclient.  You are expected to create it
manually.")
  (extra-options
   (list '())
   "Extra options will be appended to @file{ddclient.conf} file."))

(define (ddclient-account config)
  "Return the user accounts and user groups for CONFIG."
  (let ((ddclient-user (ddclient-configuration-user config))
        (ddclient-group (ddclient-configuration-group config)))
    (list (user-group
           (name ddclient-group)
           (system? #t))
          (user-account
           (name ddclient-user)
           (system? #t)
           (group ddclient-group)
           (comment "ddclientd privilege separation user")
           (home-directory (string-append "/var/run/" ddclient-user))))))

(define (ddclient-activation config)
  "Return the activation GEXP for CONFIG."
  (with-imported-modules '((guix build utils)
                           (ice-9 rdelim))
    #~(begin
        (use-modules (guix build utils)
                     (ice-9 rdelim))
        (let ((ddclient-user
               (passwd:uid (getpw #$(ddclient-configuration-user config))))
              (ddclient-group
               (passwd:gid (getpw #$(ddclient-configuration-group config))))
              (ddclient-secret-file
               #$(ddclient-configuration-secret-file config)))
          ;; 'ddclient' complains about ddclient.conf file permissions, which
          ;; rules out /gnu/store.  Thus we copy the ddclient.conf to /etc.
          (for-each (lambda (dir)
                      (mkdir-p dir)
                      (chmod dir #o700)
                      (chown dir ddclient-user ddclient-group))
                    '("/var/cache/ddclient" "/var/run/ddclient"
                      "/etc/ddclient"))
          (with-output-to-file "/etc/ddclient/ddclient.conf"
            (lambda ()
              (display
               (string-append
                "# Generated by 'ddclient-service'.\n\n"
                #$(with-output-to-string
                    (lambda ()
                      (serialize-configuration config
                                               ddclient-configuration-fields)))
                (if (string-null? ddclient-secret-file)
                    ""
                    (format #f "\n\n# Appended from '~a'.\n\n~a"
                            ddclient-secret-file
                            (with-input-from-file ddclient-secret-file
                              read-string)))))))
          (chmod "/etc/ddclient/ddclient.conf" #o600)
          (chown "/etc/ddclient/ddclient.conf"
                 ddclient-user ddclient-group)))))

(define (ddclient-shepherd-service config)
  "Return a <shepherd-service> for ddclient with CONFIG."
  (let ((ddclient (ddclient-configuration-ddclient config))
        (ddclient-pid (ddclient-configuration-pid config))
        (ddclient-user (ddclient-configuration-user config))
        (ddclient-group (ddclient-configuration-group config)))
    (list (shepherd-service
           (provision '(ddclient))
           (documentation "Run ddclient daemon.")
           (start #~(make-forkexec-constructor
                     (list #$(file-append ddclient "/bin/ddclient")
                           "-foreground"
                           "-file" "/etc/ddclient/ddclient.conf")
                     #:pid-file #$ddclient-pid
                     #:environment-variables
                     (list "SSL_CERT_DIR=/run/current-system/profile\
/etc/ssl/certs"
                           "SSL_CERT_FILE=/run/current-system/profile\
/etc/ssl/certs/ca-certificates.crt")
                     #:user #$ddclient-user
                     #:group #$ddclient-group))
           (stop #~(make-kill-destructor))))))

(define ddclient-service-type
  (service-type
   (name 'ddclient)
   (extensions
    (list (service-extension account-service-type
                             ddclient-account)
          (service-extension shepherd-root-service-type
                             ddclient-shepherd-service)
          (service-extension activation-service-type
                             ddclient-activation)))
   (default-value (ddclient-configuration))
   (description "Configure address updating utility for dynamic DNS services,
ddclient.")))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Jesse Dowell <jessedowell@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 docker)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu services base)
  #:use-module (gnu services dbus)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages docker)
  #:use-module (gnu packages linux)               ;singularity
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix packages)

  #:export (docker-configuration
            docker-service-type
            singularity-service-type))

(define-configuration docker-configuration
  (docker
   (package docker)
   "Docker daemon package.")
  (docker-cli
   (package docker-cli)
   "Docker client package.")
  (containerd
   (package containerd)
   "containerd package.")
  (proxy
   (package docker-libnetwork-cmd-proxy)
   "The proxy package to support inter-container and outside-container
loop-back communications.")
  (enable-proxy?
   (boolean #t)
   "Enable or disable the user-land proxy (enabled by default).")
  (debug?
   (boolean #f)
   "Enable or disable debug output.")
  (enable-iptables?
   (boolean #t)
   "Enable addition of iptables rules (enabled by default).")
  (no-serialization))

(define %docker-accounts
  (list (user-group (name "docker") (system? #t))))

(define (%containerd-activation config)
  (let ((state-dir "/var/lib/containerd"))
    #~(begin
        (use-modules (guix build utils))
        (mkdir-p #$state-dir))))

(define (%docker-activation config)
  (%containerd-activation config)
  (let ((state-dir "/var/lib/docker"))
    #~(begin
        (use-modules (guix build utils))
        (mkdir-p #$state-dir))))

(define (containerd-shepherd-service config)
  (let* ((package (docker-configuration-containerd config))
         (debug? (docker-configuration-debug? config))
         (containerd (docker-configuration-containerd config)))
    (shepherd-service
           (documentation "containerd daemon.")
           (provision '(containerd))
           (start #~(make-forkexec-constructor
                     (list (string-append #$package "/bin/containerd")
                           #$@(if debug?
                                  '("--log-level=debug")
                                  '()))
                     ;; For finding containerd-shim binary.
                     #:environment-variables
                     (list (string-append "PATH=" #$containerd "/bin"))
                     #:log-file "/var/log/containerd.log"))
           (stop #~(make-kill-destructor)))))

(define (docker-shepherd-service config)
  (let* ((docker (docker-configuration-docker config))
         (enable-proxy? (docker-configuration-enable-proxy? config))
         (enable-iptables? (docker-configuration-enable-iptables? config))
         (proxy (docker-configuration-proxy config))
         (debug? (docker-configuration-debug? config)))
    (shepherd-service
           (documentation "Docker daemon.")
           (provision '(dockerd))
           (requirement '(containerd
                          dbus-system
                          elogind
                          file-system-/sys/fs/cgroup/blkio
                          file-system-/sys/fs/cgroup/cpu
                          file-system-/sys/fs/cgroup/cpuset
                          file-system-/sys/fs/cgroup/devices
                          file-system-/sys/fs/cgroup/memory
                          file-system-/sys/fs/cgroup/pids
                          networking
                          udev))
           (start #~(make-forkexec-constructor
                     (list (string-append #$docker "/bin/dockerd")
                           "-p" "/var/run/docker.pid"
                           #$@(if debug?
                                  '("--debug" "--log-level=debug")
                                  '())
                           #$@(if enable-proxy?
                                  (list "--userland-proxy=true"
                                        #~(string-append
                                           "--userland-proxy-path=" #$proxy "/bin/proxy"))
                                  '("--userland-proxy=false"))
                           (if #$enable-iptables?
                               "--iptables"
                               "--iptables=false"))
                     #:pid-file "/var/run/docker.pid"
                     #:log-file "/var/log/docker.log"))
           (stop #~(make-kill-destructor)))))

(define docker-service-type
  (service-type (name 'docker)
                (description "Provide capability to run Docker application
bundles in Docker containers.")
                (extensions
                 (list
                  ;; Make sure the 'docker' command is available.
                  (service-extension profile-service-type
                                     (compose list docker-configuration-docker-cli))
                  (service-extension activation-service-type
                                     %docker-activation)
                  (service-extension shepherd-root-service-type
                                     (lambda (config)
                                       (list (containerd-shepherd-service config)
                                             (docker-shepherd-service config))))
                  (service-extension account-service-type
                                     (const %docker-accounts))))
                (default-value (docker-configuration))))

;;;
;;; Singularity.
;;;

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

        (define %mount-directory
          "/var/singularity/mnt/")

        ;; Create the directories that Singularity 2.6 expects to find.  Make
        ;; them #o755 like the 'install-data-hook' rule in 'Makefile.am' of
        ;; Singularity 2.6.1.
        (for-each (lambda (directory)
                    (let ((directory (string-append %mount-directory
                                                    directory)))
                      (mkdir-p directory)
                      (chmod directory #o755)))
                  '("container" "final" "overlay" "session"))
        (chmod %mount-directory #o755))))

(define (singularity-setuid-programs singularity)
  "Return the setuid-root programs that SINGULARITY needs."
  (define helpers
    ;; The helpers, under a meaningful name.
    (computed-file "singularity-setuid-helpers"
                   #~(begin
                       (mkdir #$output)
                       (for-each (lambda (program)
                                   (symlink (string-append #$singularity
                                                           "/libexec/singularity"
                                                           "/bin/"
                                                           program "-suid")
                                            (string-append #$output
                                                           "/singularity-"
                                                           program
                                                           "-helper")))
                                 '("action" "mount" "start")))))

  (list (file-append helpers "/singularity-action-helper")
        (file-append helpers "/singularity-mount-helper")
        (file-append helpers "/singularity-start-helper")))

(define singularity-service-type
  (service-type (name 'singularity)
                (description
                 "Install the Singularity application bundle tool.")
                (extensions
                 (list (service-extension setuid-program-service-type
                                          singularity-setuid-programs)
                       (service-extension activation-service-type
                                          (const %singularity-activation))))
                (default-value singularity)))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Simon South <simon@simonsouth.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 file-sharing)
  #:use-module (gcrypt base16)
  #:use-module (gcrypt hash)
  #:use-module (gcrypt random)
  #:use-module (gnu services)
  #:use-module (gnu services admin)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages bittorrent)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages guile)
  #:use-module (gnu system shadow)
  #:use-module (guix diagnostics)
  #:use-module (guix gexp)
  #:use-module (guix i18n)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (transmission-daemon-configuration
            transmission-daemon-service-type
            transmission-password-hash
            transmission-random-salt))

;;;
;;; Transmission Daemon.
;;;

(define %transmission-daemon-user "transmission")
(define %transmission-daemon-group "transmission")

(define %transmission-daemon-configuration-directory
  "/var/lib/transmission-daemon")
(define %transmission-daemon-log-file
  "/var/log/transmission.log")

(define %transmission-salt-length 8)

(define (transmission-password-hash password salt)
  "Returns a string containing the result of hashing @var{password} together
with @var{salt}, in the format recognized by Transmission clients for their
@code{rpc-password} configuration setting.

@var{salt} must be an eight-character string.  The
@code{transmission-random-salt} procedure can be used to generate a suitable
salt value at random."
  (if (not (and (string? salt)
                (eq? (string-length salt) %transmission-salt-length)))
      (raise (formatted-message
              (G_ "salt value must be a string of ~d characters")
              %transmission-salt-length))
      (string-append "{"
                     (bytevector->base16-string
                      (sha1 (string->utf8 (string-append password salt))))
                     salt)))

(define (transmission-random-salt)
  "Returns a string containing a random, eight-character salt value of the
type generated and used by Transmission clients, suitable for passing to the
@code{transmission-password-hash} procedure."
  ;; This implementation matches a portion of Transmission's tr_ssha1
  ;; function.  See libtransmission/crypto-utils.c in the Transmission source
  ;; distribution.
  (let ((salter (string-append "0123456789"
                               "abcdefghijklmnopqrstuvwxyz"
                               "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                               "./")))
    (list->string
     (map (lambda (u8)
            (string-ref salter (modulo u8 (string-length salter))))
          (bytevector->u8-list
           (gen-random-bv %transmission-salt-length %gcry-strong-random))))))

(define (uglify-field-name field-name)
  (string-delete #\? (symbol->string field-name)))

(define (serialize-field field-name val)
  ;; "Serialize" each configuration field as a G-expression containing a
  ;; name-value pair, the collection of which will subsequently be serialized
  ;; to disk as a JSON object.
  #~(#$(uglify-field-name field-name) . #$val))

(define serialize-boolean serialize-field)
(define serialize-integer serialize-field)
(define serialize-rational serialize-field)

(define serialize-string serialize-field)
(define-maybe string)
;; Override the definition of "serialize-maybe-string", as we need to output a
;; name-value pair for the JSON builder.
(set! serialize-maybe-string
  (lambda (field-name val)
    (serialize-string field-name
                      (if (and (symbol? val)
                               (eq? val 'disabled))
                          ""
                          val))))

(define (string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (and (string? x)
                       (not (string-index x #\,))))
                val)))
(define (serialize-string-list field-name val)
  (serialize-field field-name (string-join val ",")))

(define days
  '((sunday    . #b0000001)
    (monday    . #b0000010)
    (tuesday   . #b0000100)
    (wednesday . #b0001000)
    (thursday  . #b0010000)
    (friday    . #b0100000)
    (saturday  . #b1000000)))
(define day-lists
  (list (cons 'weekdays '(monday tuesday wednesday thursday friday))
        (cons 'weekends '(saturday sunday))
        (cons 'all (map car days))))
(define (day-list? val)
  (or (and (symbol? val)
           (assq val day-lists))
      (and (list? val)
           (and-map (lambda (x)
                      (and (symbol? x)
                           (assq x days)))
                    val))))
(define (serialize-day-list field-name val)
  (serialize-integer field-name
                     (reduce logior
                             #b0000000
                             (map (lambda (day)
                                    (assq-ref days day))
                                  (if (symbol? val)
                                      (assq-ref day-lists val)
                                      val)))))

(define encryption-modes
  '((prefer-unencrypted-connections . 0)
    (prefer-encrypted-connections   . 1)
    (require-encrypted-connections  . 2)))
(define (encryption-mode? val)
  (and (symbol? val)
       (assq val encryption-modes)))
(define (serialize-encryption-mode field-name val)
  (serialize-integer field-name (assq-ref encryption-modes val)))

(define serialize-file-like serialize-field)

(define (file-object? val)
  (or (string? val)
      (file-like? val)))
(define (serialize-file-object field-name val)
  (if (file-like? val)
      (serialize-file-like field-name val)
      (serialize-string field-name val)))
(define-maybe file-object)
(set! serialize-maybe-file-object
  (lambda (field-name val)
    (if (and (symbol? val)
             (eq? val 'disabled))
        (serialize-string field-name "")
        (serialize-file-object field-name val))))

(define (file-object-list? val)
  (and (list? val)
       (and-map file-object? val)))
(define serialize-file-object-list serialize-field)

(define message-levels
  '((none  . 0)
    (error . 1)
    (info  . 2)
    (debug . 3)))
(define (message-level? val)
  (and (symbol? val)
       (assq val message-levels)))
(define (serialize-message-level field-name val)
  (serialize-integer field-name (assq-ref message-levels val)))

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

(define (non-negative-rational? val)
  (and (rational? val)
       (not (negative? val))))
(define serialize-non-negative-rational serialize-rational)

(define (port-number? val)
  (and (integer? val)
       (>= val 1)
       (<= val 65535)))
(define serialize-port-number serialize-integer)

(define preallocation-modes
  '((none   . 0)
    (fast   . 1)
    (sparse . 1)
    (full   . 2)))
(define (preallocation-mode? val)
  (and (symbol? val)
       (assq val preallocation-modes)))
(define (serialize-preallocation-mode field-name val)
  (serialize-integer field-name (assq-ref preallocation-modes val)))

(define tcp-types-of-service
  '((default     . "default")
    (low-cost    . "lowcost")
    (throughput  . "throughput")
    (low-delay   . "lowdelay")
    (reliability . "reliability")))
(define (tcp-type-of-service? val)
  (and (symbol? val)
       (assq val tcp-types-of-service)))
(define (serialize-tcp-type-of-service field-name val)
  (serialize-string field-name (assq-ref tcp-types-of-service val)))

(define (transmission-password-hash? val)
  (and (string? val)
       (= (string-length val) 49)
       (eqv? (string-ref val 0) #\{)
       (string-every char-set:hex-digit val 1 41)))
(define serialize-transmission-password-hash serialize-string)
(define-maybe transmission-password-hash)
(set! serialize-maybe-transmission-password-hash serialize-maybe-string)

(define (umask? val)
  (and (integer? val)
       (>= val #o000)
       (<= val #o777)))
(define serialize-umask serialize-integer) ; must use decimal representation

(define-configuration transmission-daemon-configuration
  ;; Settings internal to this service definition.
  (transmission
   (package transmission)
   "The Transmission package to use.")
  (stop-wait-period
   (non-negative-integer 10)
   "The period, in seconds, to wait when stopping the service for
@command{transmission-daemon} to exit before killing its process.  This allows
the daemon time to complete its housekeeping and send a final update to
trackers as it shuts down.  On slow hosts, or hosts with a slow network
connection, this value may need to be increased.")

  ;; Files and directories.
  (download-dir
   (string (string-append %transmission-daemon-configuration-directory
                          "/downloads"))
   "The directory to which torrent files are downloaded.")
  (incomplete-dir-enabled?
   (boolean #f)
   "If @code{#t}, files will be held in @code{incomplete-dir} while their
torrent is being downloaded, then moved to @code{download-dir} once the
torrent is complete.  Otherwise, files for all torrents (including those still
being downloaded) will be placed in @code{download-dir}.")
  (incomplete-dir
   (maybe-string 'disabled)
   "The directory in which files from incompletely downloaded torrents will be
held when @code{incomplete-dir-enabled?} is @code{#t}.")
  (umask
   (umask #o022)
   "The file mode creation mask used for downloaded files.  (See the
@command{umask} man page for more information.)")
  (rename-partial-files?
   (boolean #t)
   "When @code{#t}, ``.part'' is appended to the name of partially downloaded
files.")
  (preallocation
   (preallocation-mode 'fast)
   "The mode by which space should be preallocated for downloaded files, one
of @code{none}, @code{fast} (or @code{sparse}) and @code{full}.  Specifying
@code{full} will minimize disk fragmentation at a cost to file-creation
speed.")
  (watch-dir-enabled?
   (boolean #f)
   "If @code{#t}, the directory specified by @code{watch-dir} will be watched
for new @file{.torrent} files and the torrents they describe added
automatically (and the original files removed, if
@code{trash-original-torrent-files?} is @code{#t}).")
  (watch-dir
   (maybe-string 'disabled)
   "The directory to be watched for @file{.torrent} files indicating new
torrents to be added, when @code{watch-dir-enabled} is @code{#t}.")
  (trash-original-torrent-files?
   (boolean #f)
   "When @code{#t}, @file{.torrent} files will be deleted from the watch
directory once their torrent has been added (see
@code{watch-directory-enabled?}).")

  ;; Bandwidth limits.
  (speed-limit-down-enabled?
   (boolean #f)
   "When @code{#t}, the daemon's download speed will be limited to the rate
specified by @code{speed-limit-down}.")
  (speed-limit-down
   (non-negative-integer 100)
   "The default global-maximum download speed, in kilobytes per second.")
  (speed-limit-up-enabled?
   (boolean #f)
   "When @code{#t}, the daemon's upload speed will be limited to the rate
specified by @code{speed-limit-up}.")
  (speed-limit-up
   (non-negative-integer 100)
   "The default global-maximum upload speed, in kilobytes per second.")
  (alt-speed-enabled?
   (boolean #f)
   "When @code{#t}, the alternate speed limits @code{alt-speed-down} and
@code{alt-speed-up} are used (in place of @code{speed-limit-down} and
@code{speed-limit-up}, if they are enabled) to constrain the daemon's
bandwidth usage.  This can be scheduled to occur automatically at certain
times during the week; see @code{alt-speed-time-enabled?}.")
  (alt-speed-down
   (non-negative-integer 50)
   "The alternate global-maximum download speed, in kilobytes per second.")
  (alt-speed-up
   (non-negative-integer 50)
   "The alternate global-maximum upload speed, in kilobytes per second.")

  ;; Bandwidth-limit scheduling.
  (alt-speed-time-enabled?
   (boolean #f)
   "When @code{#t}, the alternate speed limits @code{alt-speed-down} and
@code{alt-speed-up} will be enabled automatically during the periods specified
by @code{alt-speed-time-day}, @code{alt-speed-time-begin} and
@code{alt-time-speed-end}.")
  (alt-speed-time-day
   (day-list 'all)
   "The days of the week on which the alternate-speed schedule should be used,
specified either as a list of days (@code{sunday}, @code{monday}, and so on)
or using one of the symbols @code{weekdays}, @code{weekends} or @code{all}.")
  (alt-speed-time-begin
   (non-negative-integer 540)
   "The time of day at which to enable the alternate speed limits,
expressed as a number of minutes since midnight.")
  (alt-speed-time-end
   (non-negative-integer 1020)
   "The time of day at which to disable the alternate speed limits,
expressed as a number of minutes since midnight.")

  ;; Peer networking.
  (bind-address-ipv4
   (string "0.0.0.0")
   "The IP address at which to listen for peer connections, or ``0.0.0.0'' to
listen at all available IP addresses.")
  (bind-address-ipv6
   (string "::")
   "The IPv6 address at which to listen for peer connections, or ``::'' to
listen at all available IPv6 addresses.")
  (peer-port-random-on-start?
   (boolean #f)
   "If @code{#t}, when the daemon starts it will select a port at random on
which to listen for peer connections, from the range specified (inclusively)
by @code{peer-port-random-low} and @code{peer-port-random-high}.  Otherwise,
it listens on the port specified by @code{peer-port}.")
  (peer-port-random-low
   (port-number 49152)
   "The lowest selectable port number when @code{peer-port-random-on-start?}
is @code{#t}.")
  (peer-port-random-high
   (port-number 65535)
   "The highest selectable port number when @code{peer-port-random-on-start}
is @code{#t}.")
  (peer-port
   (port-number 51413)
   "The port on which to listen for peer connections when
@code{peer-port-random-on-start?} is @code{#f}.")
  (port-forwarding-enabled?
   (boolean #t)
   "If @code{#t}, the daemon will attempt to configure port-forwarding on an
upstream gateway automatically using @acronym{UPnP} and @acronym{NAT-PMP}.")
  (encryption
   (encryption-mode 'prefer-encrypted-connections)
   "The encryption preference for peer connections, one of
@code{prefer-unencrypted-connections}, @code{prefer-encrypted-connections} or
@code{require-encrypted-connections}.")
  (peer-congestion-algorithm
   (maybe-string 'disabled)
   "The TCP congestion-control algorithm to use for peer connections,
specified using a string recognized by the operating system in calls to
@code{setsockopt} (or set to @code{disabled}, in which case the
operating-system default is used).

Note that on GNU/Linux systems, the kernel must be configured to allow
processes to use a congestion-control algorithm not in the default set;
otherwise, it will deny these requests with ``Operation not permitted''.  To
see which algorithms are available on your system and which are currently
permitted for use, look at the contents of the files
@file{tcp_available_congestion_control} and
@file{tcp_allowed_congestion_control} in the @file{/proc/sys/net/ipv4}
directory.

As an example, to have Transmission Daemon use
@uref{http://www-ece.rice.edu/networks/TCP-LP/, the TCP Low Priority
congestion-control algorithm}, you'll need to modify your kernel configuration
to build in support for the algorithm, then update your operating-system
configuration to allow its use by adding a @code{sysctl-service-type}
service (or updating the existing one's configuration) with lines like the
following:

@lisp
(service sysctl-service-type
         (sysctl-configuration
          (settings
           (\"net.ipv4.tcp_allowed_congestion_control\" .
            \"reno cubic lp\"))))
@end lisp

The Transmission Daemon configuration can then be updated with

@lisp
(peer-congestion-algorithm \"lp\")
@end lisp

and the system reconfigured to have the changes take effect.")
  (peer-socket-tos
   (tcp-type-of-service 'default)
   "The type of service to request in outgoing @acronym{TCP} packets,
one of @code{default}, @code{low-cost}, @code{throughput}, @code{low-delay}
and @code{reliability}.")
  (peer-limit-global
   (non-negative-integer 200)
   "The global limit on the number of connected peers.")
  (peer-limit-per-torrent
   (non-negative-integer 50)
   "The per-torrent limit on the number of connected peers.")
  (upload-slots-per-torrent
   (non-negative-integer 14)
   "The maximum number of peers to which the daemon will upload data
simultaneously for each torrent.")
  (peer-id-ttl-hours
   (non-negative-integer 6)
   "The maximum lifespan, in hours, of the peer ID associated with each public
torrent before it is regenerated.")

  ;; Peer blocklists.
  (blocklist-enabled?
   (boolean #f)
   "When @code{#t}, the daemon will ignore peers mentioned in the blocklist it
has most recently downloaded from @code{blocklist-url}.")
  (blocklist-url
   (maybe-string 'disabled)
   "The URL of a peer blocklist (in @acronym{P2P}-plaintext or eMule
@file{.dat} format) to be periodically downloaded and applied when
@code{blocklist-enabled?} is @code{#t}.")

  ;; Queueing.
  (download-queue-enabled?
   (boolean #t)
   "If @code{#t}, the daemon will be limited to downloading at most
@code{download-queue-size} non-stalled torrents simultaneously.")
  (download-queue-size
   (non-negative-integer 5)
   "The size of the daemon's download queue, which limits the number of
non-stalled torrents it will download at any one time when
@code{download-queue-enabled?} is @code{#t}.")
  (seed-queue-enabled?
   (boolean #f)
   "If @code{#t}, the daemon will be limited to seeding at most
@code{seed-queue-size} non-stalled torrents simultaneously.")
  (seed-queue-size
   (non-negative-integer 10)
   "The size of the daemon's seed queue, which limits the number of
non-stalled torrents it will seed at any one time when
@code{seed-queue-enabled?} is @code{#t}.")
  (queue-stalled-enabled?
   (boolean #t)
   "When @code{#t}, the daemon will consider torrents for which it has not
shared data in the past @code{queue-stalled-minutes} minutes to be stalled and
not count them against its @code{download-queue-size} and
@code{seed-queue-size} limits.")
  (queue-stalled-minutes
   (non-negative-integer 30)
   "The maximum period, in minutes, a torrent may be idle before it is
considered to be stalled, when @code{queue-stalled-enabled?} is @code{#t}.")

  ;; Seeding limits.
  (ratio-limit-enabled?
   (boolean #f)
   "When @code{#t}, a torrent being seeded will automatically be paused once
it reaches the ratio specified by @code{ratio-limit}.")
  (ratio-limit
   (non-negative-rational 2.0)
   "The ratio at which a torrent being seeded will be paused, when
@code{ratio-limit-enabled?} is @code{#t}.")
  (idle-seeding-limit-enabled?
   (boolean #f)
   "When @code{#t}, a torrent being seeded will automatically be paused once
it has been idle for @code{idle-seeding-limit} minutes.")
  (idle-seeding-limit
   (non-negative-integer 30)
   "The maximum period, in minutes, a torrent being seeded may be idle before
it is paused, when @code{idle-seeding-limit-enabled?} is @code{#t}.")

  ;; BitTorrent extensions.
  (dht-enabled?
   (boolean #t)
   "Enable @uref{http://bittorrent.org/beps/bep_0005.html, the distributed
hash table (@acronym{DHT}) protocol}, which supports the use of trackerless
torrents.")
  (lpd-enabled?
   (boolean #f)
   "Enable @url{https://en.wikipedia.org/wiki/Local_Peer_Discovery, local peer
discovery} (@acronym{LPD}), which allows the discovery of peers on the local
network and may reduce the amount of data sent over the public Internet.")
  (pex-enabled?
   (boolean #t)
   "Enable @url{https://en.wikipedia.org/wiki/Peer_exchange, peer
exchange} (@acronym{PEX}), which reduces the daemon's reliance on external
trackers and may improve its performance.")
  (utp-enabled?
   (boolean #t)
   "Enable @url{http://bittorrent.org/beps/bep_0029.html, the micro transport
protocol} (@acronym{uTP}), which aims to reduce the impact of BitTorrent
traffic on other users of the local network while maintaining full utilization
of the available bandwidth.")

  ;; Remote procedure call (RPC) interface.
  (rpc-enabled?
   (boolean #t)
   "If @code{#t}, enable the remote procedure call (@acronym{RPC}) interface,
which allows remote control of the daemon via its Web interface, the
@command{transmission-remote} command-line client, and similar tools.")
  (rpc-bind-address
   (string "0.0.0.0")
   "The IP address at which to listen for @acronym{RPC} connections, or
``0.0.0.0'' to listen at all available IP addresses.")
  (rpc-port
   (port-number 9091)
   "The port on which to listen for @acronym{RPC} connections.")
  (rpc-url
   (string "/transmission/")
   "The path prefix to use in the @acronym{RPC}-endpoint @acronym{URL}.")
  (rpc-authentication-required?
   (boolean #f)
   "When @code{#t}, clients must authenticate (see @code{rpc-username} and
@code{rpc-password}) when using the @acronym{RPC} interface.  Note this has
the side effect of disabling host-name whitelisting (see
@code{rpc-host-whitelist-enabled?}.")
  (rpc-username
   (maybe-string 'disabled)
   "The username required by clients to access the @acronym{RPC} interface
when @code{rpc-authentication-required?} is @code{#t}.")
  (rpc-password
   (maybe-transmission-password-hash 'disabled)
   "The password required by clients to access the @acronym{RPC} interface
when @code{rpc-authentication-required?} is @code{#t}.  This must be specified
using a password hash in the format recognized by Transmission clients, either
copied from an existing @file{settings.json} file or generated using the
@code{transmission-password-hash} procedure.")
  (rpc-whitelist-enabled?
   (boolean #t)
   "When @code{#t}, @acronym{RPC} requests will be accepted only when they
originate from an address specified in @code{rpc-whitelist}.")
  (rpc-whitelist
   (string-list '("127.0.0.1" "::1"))
   "The list of IP and IPv6 addresses from which @acronym{RPC} requests will
be accepted when @code{rpc-whitelist-enabled?} is @code{#t}.  Wildcards may be
specified using @samp{*}.")
  (rpc-host-whitelist-enabled?
   (boolean #t)
   "When @code{#t}, @acronym{RPC} requests will be accepted only when they are
addressed to a host named in @code{rpc-host-whitelist}.  Note that requests to
``localhost'' or ``localhost.'', or to a numeric address, are always accepted
regardless of these settings.

Note also this functionality is disabled when
@code{rpc-authentication-required?} is @code{#t}.")
  (rpc-host-whitelist
   (string-list '())
   "The list of host names recognized by the @acronym{RPC} server when
@code{rpc-host-whitelist-enabled?} is @code{#t}.")

  ;; Miscellaneous.
  (message-level
   (message-level 'info)
   "The minimum severity level of messages to be logged (to
@file{/var/log/transmission.log}) by the daemon, one of @code{none} (no
logging), @code{error}, @code{info} and @code{debug}.")
  (start-added-torrents?
   (boolean #t)
   "When @code{#t}, torrents are started as soon as they are added; otherwise,
they are added in ``paused'' state.")
  (script-torrent-done-enabled?
   (boolean #f)
   "When @code{#t}, the script specified by
@code{script-torrent-done-filename} will be invoked each time a torrent
completes.")
  (script-torrent-done-filename
   (maybe-file-object 'disabled)
   "A file name or file-like object specifying a script to run each time a
torrent completes, when @code{script-torrent-done-enabled?} is @code{#t}.")
  (scrape-paused-torrents-enabled?
   (boolean #t)
   "When @code{#t}, the daemon will scrape trackers for a torrent even when
the torrent is paused.")
  (cache-size-mb
   (non-negative-integer 4)
   "The amount of memory, in megabytes, to allocate for the daemon's in-memory
cache.  A larger value may increase performance by reducing the frequency of
disk I/O.")
  (prefetch-enabled?
   (boolean #t)
   "When @code{#t}, the daemon will try to improve I/O performance by hinting
to the operating system which data is likely to be read next from disk to
satisfy requests from peers."))

(define (transmission-daemon-shepherd-service config)
  "Return a <shepherd-service> for Transmission Daemon with CONFIG."
  (let ((transmission
         (transmission-daemon-configuration-transmission config))
        (stop-wait-period
         (transmission-daemon-configuration-stop-wait-period config)))
    (list
     (shepherd-service
      (provision '(transmission-daemon transmission bittorrent))
      (requirement '(networking))
      (documentation "Share files using the BitTorrent protocol.")
      (start #~(make-forkexec-constructor
                '(#$(file-append transmission "/bin/transmission-daemon")
                  "--config-dir"
                  #$%transmission-daemon-configuration-directory
                  "--foreground")
                #:user #$%transmission-daemon-user
                #:group #$%transmission-daemon-group
                #:directory #$%transmission-daemon-configuration-directory
                #:log-file #$%transmission-daemon-log-file
                #:environment-variables
                '("CURL_CA_BUNDLE=/etc/ssl/certs/ca-certificates.crt")))
      (stop #~(lambda (pid)
                (kill pid SIGTERM)

                ;; Transmission Daemon normally needs some time to shut down,
                ;; as it will complete some housekeeping and send a final
                ;; update to trackers before it exits.
                ;;
                ;; Wait a reasonable period for it to stop before continuing.
                ;; If we don't do this, restarting the service can fail as the
                ;; new daemon process finds the old one still running and
                ;; attached to the port used for peer connections.
                (let wait-before-killing ((period #$stop-wait-period))
                  (if (zero? (car (waitpid pid WNOHANG)))
                      (if (positive? period)
                          (begin
                            (sleep 1)
                            (wait-before-killing (- period 1)))
                          (begin
                            (format #t
                                    #$(G_ "Wait period expired; killing \
transmission-daemon (pid ~a).~%")
                                    pid)
                            (display #$(G_ "(If you see this message \
regularly, you may need to increase the value
of 'stop-wait-period' in the service configuration.)\n"))
                            (kill pid SIGKILL)))))
                #f))
      (actions
       (list
        (shepherd-action
         (name 'reload)
         (documentation "Reload the settings file from disk.")
         (procedure #~(lambda (pid)
                        (if pid
                            (begin
                              (kill pid SIGHUP)
                              (display #$(G_ "Service transmission-daemon has \
been asked to reload its settings file.")))
                            (display #$(G_ "Service transmission-daemon is not \
running."))))))))))))

(define %transmission-daemon-accounts
  (list (user-group
         (name %transmission-daemon-group)
         (system? #t))
        (user-account
         (name %transmission-daemon-user)
         (group %transmission-daemon-group)
         (comment "Transmission Daemon service account")
         (home-directory %transmission-daemon-configuration-directory)
         (shell (file-append shadow "/sbin/nologin"))
         (system? #t))))

(define %transmission-daemon-log-rotations
  (list (log-rotation
         (files (list %transmission-daemon-log-file)))))

(define (transmission-daemon-computed-settings-file config)
  "Return a @code{computed-file} object that, when unquoted in a G-expression,
produces a Transmission settings file (@file{settings.json}) matching CONFIG."
  (let ((settings
         ;; "Serialize" the configuration settings as a list of G-expressions
         ;; containing a name-value pair, which will ultimately be sorted and
         ;; serialized to the settings file as a JSON object.
         (map
          (lambda (field)
            ((configuration-field-serializer field)
             (configuration-field-name field)
             ((configuration-field-getter field) config)))
          (filter
           (lambda (field)
             ;; Omit configuration fields that are used only internally by
             ;; this service definition.
             (not (memq (configuration-field-name field)
                        '(transmission stop-wait-period))))
           transmission-daemon-configuration-fields))))
    (computed-file
     "settings.json"
     (with-extensions (list guile-gcrypt guile-json-4)
       (with-imported-modules (source-module-closure '((json builder)))
         #~(begin
             (use-modules (json builder))

             (with-output-to-file #$output
               (lambda ()
                 (scm->json (sort-list '(#$@settings)
                                       (lambda (x y)
                                         (string<=? (car x) (car y))))
                            #:pretty #t)))))))))

(define (transmission-daemon-activation config)
  "Return the Transmission Daemon activation GEXP for CONFIG."
  (let ((config-dir %transmission-daemon-configuration-directory)
        (incomplete-dir-enabled
         (transmission-daemon-configuration-incomplete-dir-enabled? config))
        (incomplete-dir
         (transmission-daemon-configuration-incomplete-dir config))
        (watch-dir-enabled
         (transmission-daemon-configuration-watch-dir-enabled? config))
        (watch-dir
         (transmission-daemon-configuration-watch-dir config)))
    (with-imported-modules (source-module-closure '((guix build utils)))
      #~(begin
          (use-modules (guix build utils))

          (let ((owner (getpwnam #$%transmission-daemon-user)))
            (define (mkdir-p/perms directory perms)
              (mkdir-p directory)
              (chown directory (passwd:uid owner) (passwd:gid owner))
              (chmod directory perms))

            ;; Create the directories Transmission Daemon is configured to use
            ;; and assign them suitable permissions.
            (for-each (lambda (directory-specification)
                        (apply mkdir-p/perms directory-specification))
                      '(#$@(append
                            `((,config-dir #o750))
                            (if incomplete-dir-enabled
                                `((,incomplete-dir #o750))
                                '())
                            (if watch-dir-enabled
                                `((,watch-dir #o770))
                                '())))))

          ;; Generate and activate the daemon's settings file, settings.json.
          (activate-special-files
           '((#$(string-append config-dir "/settings.json")
              #$(transmission-daemon-computed-settings-file config))))))))

(define transmission-daemon-service-type
  (service-type
   (name 'transmission)
   (extensions
    (list (service-extension shepherd-root-service-type
                             transmission-daemon-shepherd-service)
          (service-extension account-service-type
                             (const %transmission-daemon-accounts))
          (service-extension rottlog-service-type
                             (const %transmission-daemon-log-rotations))
          (service-extension activation-service-type
                             transmission-daemon-activation)))
   (default-value (transmission-daemon-configuration))
   (description "Share files using the BitTorrent protocol.")))

(define (generate-transmission-daemon-documentation)
  (generate-documentation
   `((transmission-daemon-configuration
      ,transmission-daemon-configuration-fields))
   'transmission-daemon-configuration))


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

(define-module (gnu services games)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages games)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:export (wesnothd-configuration
            wesnothd-configuration?
            wesnothd-service-type))

;;;
;;; The Battle for Wesnoth server
;;;

(define-record-type* <wesnothd-configuration>
  wesnothd-configuration make-wesnothd-configuration wesnothd-configuration?
  (package wesnothd-configuration-package
           (default wesnoth-server))
  (port wesnothd-configuration-port
        (default 15000)))

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

(define wesnothd-shepherd-service
  (match-lambda
    (($ <wesnothd-configuration> package port)
     (with-imported-modules (source-module-closure
                             '((gnu build shepherd)))
       (shepherd-service
        (documentation "The Battle for Wesnoth server")
        (provision '(wesnoth-daemon))
        (requirement '(networking))
        (modules '((gnu build shepherd)))
        (start #~(make-forkexec-constructor/container
                  (list #$(file-append package "/bin/wesnothd")
                        "-p" #$(number->string port))
                  #:user "wesnothd" #:group "wesnothd"))
        (stop #~(make-kill-destructor)))))))

(define wesnothd-service-type
  (service-type
   (name 'wesnothd)
   (description
    "Run The Battle for Wesnoth server @command{wesnothd}.")
   (extensions
    (list (service-extension account-service-type
                             (const %wesnothd-accounts))
          (service-extension shepherd-root-service-type
                             (compose list wesnothd-shepherd-service))))
   (default-value (wesnothd-configuration))))