~whereiseveryone/guixrus

255875f7d86e92bb64006a59be26c64430c0c046 — Joshua Branson 1 year, 6 months ago d6035c7
Add opensmtpd-service-type.
1 files changed, 2703 insertions(+), 0 deletions(-)

A guixrus/services/opensmtpd.scm
A guixrus/services/opensmtpd.scm => guixrus/services/opensmtpd.scm +2703 -0
@@ 0,0 1,2703 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au>
;;; Copyright © 2017, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Kristofer Buffington <kristoferbuffington@gmail.com>
;;; Copyright © 2020 Jonathan Brielmaier <jonathan.brielmaier@web.de>
;;; Copyright © 2022 Joshua Branson <jbranso@gnucode.me>
;;;
;;; 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>.
;;;
;;; Some of the help text was taken from the default dovecot.conf files.

(define-module (guixrus services opensmtpd)
  #: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 system setuid)
  #:use-module (gnu packages mail)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages dav)
  #:use-module (gnu packages tls)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:export (opensmtpd-table
            opensmtpd-table?
            opensmtpd-table-name
            opensmtpd-table-data

            opensmtpd-ca
            opensmtpd-ca?
            opensmtpd-ca-name
            opensmtpd-ca-file

            opensmtpd-pki
            opensmtpd-pki?
            opensmtpd-pki-domain
            opensmtpd-pki-cert
            opensmtpd-pki-key
            opensmtpd-pki-dhe

            opensmtpd-local-delivery
            opensmtpd-local-delivery?
            opensmtpd-local-delivery-method
            opensmtpd-local-delivery-alias
            opensmtpd-local-delivery-ttl
            opensmtpd-local-delivery-user
            opensmtpd-local-delivery-userbase
            opensmtpd-local-delivery-virtual
            opensmtpd-local-delivery-wrapper

            opensmtpd-maildir
            opensmtpd-maildir?
            opensmtpd-maildir-pathname
            opensmtpd-maildir-junk

            opensmtpd-mda
            opensmtpd-mda-name
            opensmtpd-mda-command

            opensmtpd-lmtp
            opensmtpd-lmtp-destination
            opensmtpd-lmtp-rcpt

            opensmtpd-relay
            opensmtpd-relay?
            opensmtpd-relay-name
            opensmtpd-relay-backup
            opensmtpd-relay-backup-mx
            opensmtpd-relay-helo
            opensmtpd-relay-domain
            opensmtpd-relay-host
            opensmtpd-relay-pki
            opensmtpd-relay-srs
            opensmtpd-relay-tls
            opensmtpd-relay-auth
            opensmtpd-relay-mail-from
            opensmtpd-relay-src

            opensmtpd-option
            opensmtpd-option?
            opensmtpd-option-option
            opensmtpd-option-bool
            opensmtpd-option-regex
            opensmtpd-option-data

            opensmtpd-filter-phase
            opensmtpd-filter-phase?
            opensmtpd-filter-phase-name
            opensmtpd-filter-phase-phase
            opensmtpd-filter-phase-options
            opensmtpd-filter-phase-decision
            opensmtpd-filter-phase-message
            opensmtpd-filter-phase-value

            opensmtpd-filter
            opensmtpd-filter?
            opensmtpd-filter-name
            opensmtpd-filter-proc

            opensmtpd-interface
            opensmtpd-interface?
            opensmtpd-interface-interface
            opensmtpd-interface-family
            opensmtpd-interface-auth
            opensmtpd-interface-auth-optional
            opensmtpd-interface-filters
            opensmtpd-interface-hostname
            opensmtpd-interface-hostnames
            opensmtpd-interface-mask-src
            opensmtpd-interface-disable-dsn
            opensmtpd-interface-pki
            opensmtpd-interface-port
            opensmtpd-interface-proxy-v2
            opensmtpd-interface-received-auth
            opensmtpd-interface-senders
            opensmtpd-interface-masquerade
            opensmtpd-interface-secure-connection
            opensmtpd-interface-tag

            opensmtpd-socket
            opensmtpd-socket?
            opensmtpd-socket-filters
            opensmtpd-socket-mask-src
            opensmtpd-socket-tag

            opensmtpd-match
            opensmtpd-match?
            opensmtpd-match-action
            opensmtpd-match-options

            opensmtpd-smtp
            opensmtpd-smtp?
            opensmtpd-smtp-ciphers
            opensmtpd-smtp-limit-max-mails
            opensmtpd-smtp-limit-max-rcpt
            opensmtpd-smtp-max-message-size
            opensmtpd-smtp-sub-addr-delim character

            opensmtpd-srs
            opensmtpd-srs?
            opensmtpd-srs-key
            opensmtpd-srs-backup-key
            opensmtpd-srs-ttl-delay

            opensmtpd-queue
            opensmtpd-queue?
            opensmtpd-queue-compression
            opensmtpd-queue-encryption
            opensmtpd-queue-ttl-delay

            opensmtpd-configuration
            opensmtpd-configuration?
            opensmtpd-package
            opensmtpd-config-file
            opensmtpd-configuration-bounce
            opensmtpd-configuration-cas
            opensmtpd-configuration-interfaces
            opensmtpd-configuration-socket
            opensmtpd-configuration-includes
            opensmtpd-configuration-matches
            ;;opensmtpd-configuration-mda-wrappers
            opensmtpd-configuration-mta-max-deferred
            opensmtpd-configuration-srs
            opensmtpd-configuration-smtp
            opensmtpd-configuration-queue
            opensmtpd-service-type))

;;; Commentary:
;;;
;;; This module provides service definitions for the Dovecot POP3 and IMAP
;;; mail server.
;;;
;;; Code:
;;;
;;; OpenSMTPD.
;;;
;;; This next bit of code helps me create my own sanitizer functions.

;; some fieldnames have a default value of #f, which is ok.  They cannot have
;; a value of #t.
;; for example opensmtpd-table-data can be #f, BUT NOT true.
;; my/sanitize procedure tests values to see if they are of the right kind.
;; procedure false? is needed to allow fields like 'values' to be blank,
;; (empty), or #f BUT also have a value like a list of strings.
(define (false? var)
  (eq? #f var))

;; TODO I have to have this procedure, or I need to change my/sanitize
;; procedure.
(define (my-file-exists? file)
  (and (string? file)
       (access? file F_OK)))

;; This procedure takes in a var and a list of procedures.  It loops through
;; list of procedures passing in var to each.
;; if one procedure returns #t, the function returns true.  Otherwise #f.
;; TODO for fun rewrite this using map
;; If I rewrote it in map, then it may help with sanitizing.
;; eg: I could then potentially easily sanitize vars with lambda procedures.
(define (is-value-right-type? var list-of-procedures record fieldname)
  (if (null? list-of-procedures)
      #f
      (if ((car list-of-procedures) var)
          #t
          (is-value-right-type? var (cdr list-of-procedures) record
                                fieldname))))

;; converts strings like this:
;; "apple, ham, cherry" -> "apple, ham, or cherry"
;; "pineapple" -> "pinneapple".
;; "cheese, grapefruit, or jam" -> "cheese, grapefruit, or jam"
(define (add-comma-or string)
  (define last-comma-location (string-rindex string #\,))
  (if last-comma-location
      (if (string-contains string ", or" last-comma-location)
          string
          (string-replace string ", or" last-comma-location
                          (+ 1 last-comma-location)))
      string))


(define (list-of-procedures->string procedures)
  (define string
    (let loop ((procedures procedures))
      (if (null? procedures)
          ""
          (begin
            (string-append
             (cond ((eq? false? (car procedures))
                    "#f, ")
                   ((eq? boolean? (car procedures))
                    "a boolean, ")
                   ((eq? string? (car procedures))
                    "a string, ")
                   ((eq? integer? (car procedures))
                    "an integer, ")
                   ((eq? list-of-strings? (car procedures))
                    "a list of strings, ")
                   ((eq? assoc-list? (car procedures))
                    "an association list of strings, ")
                   ((eq? nested-list? (car procedures))
                    "a nested-list of strings, ")
                   ((eq? opensmtpd-pki? (car procedures))
                    "an <opensmtpd-pki> record, ")
                   ((eq? opensmtpd-table? (car procedures))
                    "an <opensmtpd-table> record, ")
                   ((eq? list-of-opensmtpd-match? (car procedures))
                    "a list of unique <opensmtpd-match> records, ")
                   ((eq? list-of-strings-or-gexps? (car procedures))
                    "a list of strings or gexps, ")
                   ;; TODO can I remove the next two procedures?
                   ;; tables-data-are-a* ?  I think I can.
                   ((eq? tables-data-are-assoc-list? (car procedures))
                    (string-append
                     "an <opensmtpd-table> record whose fieldname 'data' are "
                     "an assoc-list.\nFor example: (opensmtpd-table  "
                     "(name \"hostnames\") , "
                     "(data '((\"124.394.23.1\" . \"gnu.org\"))))"))
                   ((eq? tables-data-are-a-list-of-strings?
                         (car procedures))
                    (string-append
                     "on <opensmtpd-table> record whose fieldname 'data' is "
                     "a list of strings.\n"
                     "For example: (opensmtpd-table (name \"domains\") , "
                     "(data (list \"gnu.org\" \"guix.gnu.org\")))"))
                   ((eq? my-file-exists? (car procedures))
                    "a file, ")
                   (else "has an incorrect value, "))
             (loop (cdr procedures)))))))
  (add-comma-or (string-append (string-drop-right string 2) ".\n")))

(define (list-of-strings-or-gexps? list)
  (and (list? list)
       (cond ((null? list)
              #t)
             ((or (string? (car list))
                  (gexp? (car list))
                  (local-file? (car list))
                  (file-append? (car list))
                  (plain-file? (car list))
                  (computed-file? (car list))
                  (program-file? (car list)))
              (list-of-strings-or-gexps? (cdr list)))
             (else #f))))

(define (my/sanitize var record fieldname list-of-procedures)
  (define try-string
    (string-append "Try " (list-of-procedures->string list-of-procedures)))
  (if (is-value-right-type? var list-of-procedures record fieldname)
      var
      (begin
        (cond ((string? var)
               (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var))
              ((or (number? var) (boolean? var))
              (report-error (G_ "(~a ~a) is invalid.~%") fieldname var) )
              (else
               (report-error (G_ "(~a ...) is invalid.~%Value is: ~a~%")
                             fieldname var)))
        (display-hint (G_ try-string))
        (throw 'bad! var))))

;;; The Opensmtpd records.

;; Some example opensmtpd-tables:
;;
;;  (opensmtpd-table (name "root accounts")
;;                   (data '(("joshua" . "root@dismail.de")
;;                           ("joshua" . "postmaster@dismail.de"))))
;;  (opensmtpd-table (name "root accounts")
;;                   (data (list "mysite.me" "your-site.com")))
;;  TODO: How am I supporting file: or db: tables?
;;  Perhaps I should just automatically convert the table to a database table
;;  if the data gets large enough.  What would be sufficently large enough?
(define-record-type* <opensmtpd-table>
  opensmtpd-table make-opensmtpd-table
  opensmtpd-table?
  (name opensmtpd-table-name ;; string
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-table" "name"
                                 (list string?)))))
  ;; FIXME Support an aliasing table as described here:
  ;; https://man.openbsd.org/table.5
  ;; One may have to use the record file for this.  I don't think tables
  ;; support a table like this:
  ;; table "name" { joshua = joshua@gnucode.me,joshua@gnu-hurd.com, \
  ;;    joshua@propernaming.org, root = root@gnucode.me }
  ;; If values is an absolute filename, then it will use said filename to
  ;; house the table info. filename must be an absolute filename.
  (data opensmtpd-table-data
          (default #f)
          (sanitize (lambda (var)
                      (my/sanitize var "opensmtpd-table" "data"
                                   (list list-of-strings? assoc-list?
                                         nested-list?))))))

(define-record-type* <opensmtpd-ca>
  opensmtpd-ca make-opensmtpd-ca
  opensmtpd-ca?
  (name opensmtpd-ca-name
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-ca" "name" (list string?)))))
  (file opensmtpd-ca-file
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-ca" "file"
                                 (list my-file-exists?))))))

(define-record-type* <opensmtpd-pki>
  opensmtpd-pki make-opensmtpd-pki
  opensmtpd-pki?
  (domain opensmtpd-pki-domain
          (default #f)
          (sanitize (lambda (var)
                      (my/sanitize var "opensmtpd-pki" "domain"
                                   (list string?)))))
  ;; TODO/FIXME this should probably be a list of files.  The opensmtpd
  ;; documentation says that you could have a list of files:
  ;;
  ;; pki pkiname cert certfile
  ;; Associate certificate file certfile with host pkiname, and use that file
  ;; to prove the identity of the mail server to clients.  pkiname is the
  ;; server's name, derived from the default hostname or set using either
  ;; /gnu/store/2d13sdz76ldq8zgwv4wif0zx7hkr3mh2-opensmtpd-6.8.0p2/etc/mailname
  ;; or using the hostname directive.  If a fallback certificate or SNI is
  ;; wanted, the ‘*’ wildcard may be used as pkiname.

  ;; A certificate chain may be created by appending one or many certificates,
  ;; including a Certificate Authority certificate, to certfile.  The creation
  ;; of certificates is documented in starttls(8).
  (cert opensmtpd-pki-cert
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-pki" "cert"
                                 (list my-file-exists?)))))
  (key opensmtpd-pki-key
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-pki" "key"
                                (list my-file-exists?)))))
  ; todo sanitize this. valid parameters are "none", "legacy", or "auto".
  (dhe opensmtpd-pki-dhe
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-dhe" "dhe"
                                (list false? string?))))))

(define-record-type* <opensmtpd-lmtp>
  opensmtpd-lmtp make-opensmtpd-lmtp
  opensmtpd-lmtp?
  (destination opensmtpd-lmtp-destination
               (default #f)
               (sanitize (lambda (var)
                           (my/sanitize var "opensmtpd-lmtp" "destination"
                                        (list string?)))))
  (rcpt-to opensmtpd-lmtp-rcpt-to
           (default #f)
           (sanitize (lambda (var)
                       (my/sanitize var "opensmtpd-lmtp" "rcpt-to"
                                    (list false? string?))))))

(define-record-type* <opensmtpd-mda>
  opensmtpd-mda make-opensmtpd-mda
  opensmtpd-mda?
  (name opensmtpd-mda-name
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-mda" "name"
                                 (list string?)))))
  ;; TODO should I allow this command to be a gexp?
  (command opensmtpd-mda-command
           (default #f)
           (sanitize (lambda (var)
                       (my/sanitize var "opensmtpd-mda" "command"
                                    (list string?))))))

(define-record-type* <opensmtpd-maildir>
  opensmtpd-maildir make-opensmtpd-maildir
  opensmtpd-maildir?
  (pathname opensmtpd-maildir-pathname
            (default #f)
            (sanitize (lambda (var)
                        (my/sanitize var "opensmtpd-maildir" "pathname"
                                     (list false? string?)))))
  (junk opensmtpd-maildir-junk
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-maildir" "junk"
                                 (list boolean?))))))

(define-record-type* <opensmtpd-local-delivery>
  opensmtpd-local-delivery make-opensmtpd-local-delivery
  opensmtpd-local-delivery?
  (name opensmtpd-local-delivery-name
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-local-delivery" "name"
                                 (list string?)))))
  (method opensmtpd-local-delivery-method
          (default "mbox")
          (sanitize (lambda (var)
                      (define fieldname "method")
                      (define options (list "mbox" "expand-only"
                                            "forward-only"))
                      (define options-plus-records
                            (append options (list "(opensmtpd-lmtp ...)"
                                                  "(opensmtpd-maildir ...)"
                                                  "(opensmtpd-mda ...)")))
                      (cond ((or (opensmtpd-lmtp? var)
                                 (opensmtpd-maildir? var)
                                 (opensmtpd-mda? var)
                                 (member var options))
                             var)
                            (else
                             (begin
                               (report-error (G_ "(~a \"~a\") is invalid.~%")
                                             fieldname var)
                               (display-hint
                                (G_ (hint-string
                                     var
                                     options-plus-records
                                     #:fieldname fieldname)))
                               (throw 'bad! var)))))))
  (alias opensmtpd-local-delivery-alias
         (default #f)
         (sanitize (lambda (var)
                     (my/sanitize var "opensmtpd-local-delivery" "alias"
                                  (list false?
                                        tables-data-are-assoc-list?)))))
  (ttl opensmtpd-local-delivery-ttl
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-local-delivery" "ttl"
                                (list false? string?)))))
  (user opensmtpd-local-delivery-user
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-local-delivery" "user"
                                 (list false? string?)))))
  (userbase opensmtpd-local-delivery-userbase
            (default #f)
            (sanitize (lambda (var)
                        (my/sanitize var "opensmtpd-local-delivery" "userbase"
                                (list false?
                                      tables-data-are-assoc-list?)))))
  (virtual opensmtpd-local-delivery-virtual
           (default #f)
           (sanitize (lambda (var)
                       (my/sanitize var "opensmtpd-local-delivery" "virtual"
                                    (list
                                     false?
                                     tables-data-are-assoc-list?)))))
  (wrapper opensmtpd-local-delivery-wrapper
           (default #f)
           (sanitize (lambda (var)
                       (my/sanitize var "opensmtpd-local-delivery" "wrapper"
                                    (list false? string?))))))

(define-record-type* <opensmtpd-relay>
  opensmtpd-relay make-opensmtpd-relay
  opensmtpd-relay?
  (name opensmtpd-relay-name
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-relay" "name"
                                 (list string?))))
        (default #f))
  (backup opensmtpd-relay-backup ;; boolean
          (default #f)
          (sanitize (lambda (var)
                      (my/sanitize var "opensmtpd-relay" "backup"
                                   (list boolean?)))))
  (backup-mx opensmtpd-relay-backup-mx ;; string mx name
             (default #f)
             (sanitize (lambda (var)
                         (my/sanitize var "opensmtpd-relay" "backup-mx"
                                      (list false? string?)))))
  (helo opensmtpd-relay-helo
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-relay" "helo"
                                 (list false? string?))))
        (default #f))
  (helo-src opensmtpd-relay-helo-src
        (sanitize (lambda (var)
                      (my/sanitize var "opensmtpd-relay" "helo-src"
                                   (list false? string?
                                         tables-data-are-assoc-list?))))
        (default #f))
  (domain opensmtpd-relay-domain
          (sanitize (lambda (var)
                      (my/sanitize var "opensmtpd-relay" "domain"
                                   (list false? opensmtpd-table?))))
          (default #f))
  (host opensmtpd-relay-host
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-relay" "host"
                                 (list false? string?))))
        (default #f))
  (pki opensmtpd-relay-pki
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-relay" "pki"
                                (list false? opensmtpd-pki?)))))
  (srs opensmtpd-relay-srs
       (default #f)
       (lambda (var)
         (my/sanitize var "opensmtpd-relay" "srs"
                      (list boolean?))))
  (tls opensmtpd-relay-tls
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-relay" "tls"
                                (list false? string?)))))
  ;; the table here looks like:
  ;; label1    user:password
  ;; label2    user2:password2
  ;; It is documented in the credentials table in man table
  (auth opensmtpd-relay-auth
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-relay" "auth"
                                 (list false?
                                       tables-data-are-assoc-list?))))
        (default #f))
  (mail-from opensmtpd-relay-mail-from
             (sanitize (lambda (var)
                         (my/sanitize var "opensmtpd-relay" "mail-from"
                                      (list false? string?))))
             (default #f))
  ;; string "127.0.0.1" or "<interface>" or "<table of IP addresses>"
  ;; TODO should I do some sanitizing to make sure that the string?
  ;; here is actually an IP address or a valid interface?
  (src opensmtpd-relay-src
       (sanitize
        (lambda (var)
          (my/sanitize var "opensmtpd-relay" "src"
                       (list false? string?
                             tables-data-are-a-list-of-strings?))))
       (default #f)))

;; this record is used by <opensmtpd-filter-phase> &
;; <opensmtpd-match>
(define-record-type* <opensmtpd-option>
  opensmtpd-option make-opensmtpd-option
  opensmtpd-option?
  (option opensmtpd-option-option
          (default #f)
          (sanitize (lambda (var)
                      (my/sanitize var "opensmtpd-option" "option"
                                   (list string?)))))
  (bool opensmtpd-option-bool
       (default #t)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-option" "not"
                                (list boolean?)))))
  (regex opensmtpd-option-regex
         (default #f)
         (sanitize (lambda (var)
                     (my/sanitize var "opensmtpd-option" "regex"
                                  (list boolean?)))))
  (data opensmtpd-option-data
         (default #f)
         (sanitize (lambda (var)
                     (my/sanitize var "opensmtpd-option" "data"
                                  (list false? string? opensmtpd-table?))))))

(define-record-type* <opensmtpd-filter-phase>
  opensmtpd-filter-phase make-opensmtpd-filter-phase
  opensmtpd-filter-phase?
  (name opensmtpd-filter-phase-name ;; string
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-filter-phase" "name"
                                 (list string?)))))
  (phase opensmtpd-filter-phase-phase ;; string
              (default #f)
              (sanitize
               (lambda (var)
                 (define options
                   (list "connect" "helo" "ehlo" "mail-from"
                         "rcpt-to" "data" "commit"))
                 (define fieldname "phase")
                 (if (and (string? var)
                          (member var options))
                     var
                     (begin
                       (report-error
                        (G_
                         "(opensmtpd-filter-phase ... (~a \"~a\")) is invalid.~%")
                        fieldname var)
                       (display-hint
                        (G_ (hint-string var options
                                         #:fieldname fieldname)))
                       (throw 'bad! var))))))
  (options opensmtpd-filter-phase-options
           (default #f)
           (sanitize
            (lambda (var)
              (cond
               ((false? var)
                (report-error (G_ ""))
                (display "(opensmtpd-filter-phase (options #f)) is invalid.\n")
                (display-hint
                 (G_ "Try a list of (opensmtpd-option) records.\n"))
                (throw 'bad! #f))
               ((not (list-of-opensmtpd-option? var))
                (report-error (G_ ""))
                (display "(opensmtpd-filter-phase (options ...) is invalid.\n")
                (display-hint
                 (G_ "Try a list of (opensmtpd-option) records.\n"))
                (throw 'bad! var))
               (else (sanitize-options-for-filter-phase var))))))
  (decision opensmtpd-filter-phase-decision
            (default #f)
            (sanitize
             (lambda (var)
               (define options
                 (list "bypass" "disconnect"
                       "reject" "rewrite" "junk"))
               (define fieldname "decision")
               (if (and (string? var)
                        (member var options))
                   var
                   (begin
                     (report-error (G_ "(~a \"~a\") is invalid.~%")
                                   fieldname var)
                     (display-hint (G_ (hint-string var options
                                                    #:fieldname fieldname)))
                     (throw 'bad! var))))))
  (message opensmtpd-filter-phase-message
           (default #f)
           (sanitize (lambda (var)
                       (my/sanitize var "opensmtpd-filter-phase" "message"
                                    (list false? string?)))))
  (value opensmtpd-filter-phase-value
         (default #f)
         (sanitize (lambda (var)
                     (my/sanitize var "opensmtpd-filter-phase" "value"
                                  (list false? number?))))))

(define-record-type* <opensmtpd-filter>
  opensmtpd-filter make-opensmtpd-filter
  opensmtpd-filter?
  (name opensmtpd-filter-name
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-filter" "name"
                                 (list string?)))))
  (exec opensmtpd-filter-exec
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-filter" "exec"
                                 (list boolean?)))))
  ;; a string like "rspamd" or the command to start it like
  ;; "/path/to/rspamd --option=arg --2nd-option=arg2"
  ;; OR a list of strings and/or geps.
  (proc opensmtpd-filter-proc
             (default #f)
             (sanitize (lambda (var)
                         (my/sanitize var "opensmtpd-filter" "proc"
                                      (list string?
                                            list-of-strings-or-gexps?))))))

;; There is another type of filter that opensmtpd supports, which is a
;; filter chain. A filter chain is a list of <opensmtpd-filter-phase>s
;; and/or <opensmtpd-filter>s. This lets you apply several filters under
;; one filter name.  I could have defined a record type for it, but the
;; record would only have had two fields: name and list-of-filters.
;; Why write that as a record?  It makes the user of this service harder.
;; Instead, just define it as a list, and if a user wants an interface
;; to make multiple filters, he just appends to the 'filters' fieldname.
;;
;; returns #t if list is a unique list of <opensmtpd-filter> or
;; <opensmtpd-filter-phase>
;; returns # otherwise
(define (opensmtpd-filter-chain? %filters)
  (and (list-of-unique-filter-or-filter-phase? %filters)
       (< 1 (length %filters))))

(define-record-type* <opensmtpd-interface>
  opensmtpd-interface make-opensmtpd-interface
  opensmtpd-interface?
  ;; interface may be an IP address, interface group, or domain name
  (interface opensmtpd-interface-interface
             (default "lo")
             (sanitize (lambda (var)
                         (my/sanitize var "interface" "interface"
                                      (list string?)))))
  (family opensmtpd-interface-family
          (default #f)
          (sanitize
           (lambda (var)
             (define options (list "inet4" "inet6"))
             (define fieldname "family")
             (cond
              ((eq? #f var) ;; var == #f
               var)
              ((and (string? var)
                    (member var options))
               var)
              (else
               (begin
                 (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var)
                 (display-hint (G_ (hint-string var options
                                                #:fieldname fieldname)))
                 (throw 'bad! var)))))))
  (auth opensmtpd-interface-auth
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-interface" "auth"
                                 (list boolean?
                                       tables-data-are-assoc-list?)))))
  (auth-optional opensmtpd-interface-auth-optional
                 (default #f)
                 (sanitize
                  (lambda (var)
                    (my/sanitize var "opensmtpd-interface" "auth-optional"
                                 (list boolean?
                                       tables-data-are-assoc-list?)))))
  ;; TODO add a ca entry?
  ;; string FIXME/TODO sanitize this to support a gexp.  That way way the
  ;; includes directive can include my hacky scheme code that I use
  ;; for opensmtpd-dkimsign.
  (filters opensmtpd-interface-filters
           (default #f)
           (sanitize (lambda (var)
                       (sanitize-socket-and-interfaces-filters var))))
  (hostname opensmtpd-interface-hostname
            (default #f)
            (sanitize (lambda (var)
                        (my/sanitize var "opensmtpd-interface" "hostname"
                                     (list false? string?)))))
  (hostnames opensmtpd-interface-hostnames
             (default #f)
             (sanitize (lambda (var)
                         (my/sanitize var "opensmtpd-interface" "hostnames"
                                      (list
                                       false?
                                       tables-data-are-assoc-list?)))))
  (mask-src opensmtpd-interface-mask-src
            (default #f)
            (sanitize (lambda (var)
                        (my/sanitize var "opensmtpd-interface" "mask-src"
                                     (list boolean?)))))
  (disable-dsn opensmtpd-interface-disable-dsn
          (default #f))
  (pki opensmtpd-interface-pki
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-interface" "pki"
                                (list false? opensmtpd-pki?)))))
  (port opensmtpd-interface-port
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-interface" "port"
                                 (list false? integer?)))))
  (proxy-v2 opensmtpd-interface-proxy-k2
            (default #f))
  (received-auth opensmtpd-interface-received-auth
                 (default #f))
  (senders opensmtpd-interface-senders
           (sanitize (lambda (var)
                       (my/sanitize var "opensmtpd-interface" "senders"
                                    (list false?
                                          tables-data-are-assoc-list?))))
           (default #f))
  (masquerade opensmtpd-interface-masquerade
              (sanitize (lambda (var)
                          (my/sanitize var "opensmtpd-interface" "masquerade"
                                       (list boolean?))))
              (default #f))
  (secure-connection opensmtpd-interface-secure-connection
                     (default #f)
                     (sanitize
                      (lambda (var)
                        (define options
                          (list "smtps" "tls" "tls-require"
                                "tls-require-verify"))
                        (define fieldname "secure-connection")
                        (cond ((boolean? var)
                               var)
                              ((and (string? var)
                                    (member var options))
                               var)
                              (else
                               (begin
                                 (report-error
                                  (G_ "(~a \"~a\") is invalid.~%")
                                  fieldname var)
                                 (display-hint
                                  (G_ (hint-string var options
                                                   #:fieldname fieldname)))
                                 (throw 'bad! var)))))))
  (tag opensmtpd-interface-tag
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-interface" "tag"
                                (list false? string?))))
       (default #f)))

(define-record-type* <opensmtpd-socket>
  opensmtpd-socket make-opensmtpd-socket
  opensmtpd-socket?
  ;; false or <opensmtpd-filter> or list of <opensmtpd-filter>
  (filters opensmtpd-socket-filters
           (sanitize (lambda (var)
                       (sanitize-socket-and-interfaces-filters
                        var
                        #:socket-or-interface "socket")))
          (default #f))
  (mask-src opensmtpd-socket-mask-src
            (default #f)
            (my/sanitize var "opensmtpd-interface" "mask-src"
                                (list false? boolean?)))
  (tag opensmtpd-socket-tag
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-interface" "tag"
                                (list false? string?))))
       (default #f)))


(define-record-type* <opensmtpd-match>
  opensmtpd-match make-opensmtpd-match
  opensmtpd-match?
  ;;TODO? Perhaps I should add in a reject fieldname.  If reject
  ;;is #t, then the match record will be a reject match record.
  ;; (opensmtpd-match (reject #t)) vs. (opensmtpd-match (action 'reject))
  ;; To do this, I will also have to 'reject' mutually exclusive.
  ;; AND an match with 'reject' can have no action defined.
  (action opensmtpd-match-action
          (default #f)
          (sanitize
           (lambda (var)
             (define fieldname "action")
             (if (or (opensmtpd-relay? var)
                     (opensmtpd-local-delivery? var)
                     (eq? (quote reject) var))
                 var
                 (begin
                   (report-error (G_ "(~a \"~a\") is invalid.~%")
                                 fieldname var)
                   (display-hint
                    (G_ "Try an (opensmtpd-relay) record,
(opensmtpd-local-delivery) record, or (quote reject)."))
                   (throw 'bad! var))))))
  (options opensmtpd-match-options
           (default #f)
           (sanitize (lambda (var)
                       (sanitize-options-for-opensmtpd-match var)))))

(define-record-type* <opensmtpd-smtp>
  opensmtpd-smtp make-opensmtpd-smtp
  opensmtpd-smtp?
  (ciphers opensmtpd-smtp-ciphers
           (default #f)
           (sanitize (lambda (var)
                       (my/sanitize var "opensmtpd-smtp" "ciphers"
                                    (list false? string?)))))
  (limit-max-mails opensmtpd-smtp-limit-max-mails
                   (default #f)
                   (sanitize (lambda (var)
                               (my/sanitize var "opensmtpd-smtp"
                                            "limit-max-mails"
                                            (list false? integer?)))))
  (limit-max-rcpt opensmtpd-smtp-limit-max-rcpt
                  (default #f)
                  (sanitize (lambda (var)
                              (my/sanitize var "opensmtpd-smtp"
                                           "limit-max-rcpt"
                                           (list false? integer?)))))
  ;; TODO the user could enter in "zebra" which would break the config.
  ;; I should sanitize the string to make sure it looks like "50M".
  (max-message-size opensmtpd-smtp-max-message-size
                    (default #f)
                    (sanitize (lambda (var)
                                (my/sanitize var "opensmtpd-smtp"
                                             "max-message-size"
                                             (list false? integer?
                                                   string?)))))
  ;; FIXME/TODO the sanitize function of sub-addr-delim should accept a
  ;; string of length one not string?
  (sub-addr-delim opensmtpd-smtp-sub-addr-delim
                  (default #f)
                  (sanitize (lambda (var)
                              (my/sanitize var "opensmtpd-smtp"
                                           "sub-addr-delim"
                                           (list false? integer? string?))))))

(define-record-type* <opensmtpd-srs>
  opensmtpd-srs make-opensmtpd-srs
  opensmtpd-srs?
  (key opensmtpd-srs-key
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-srs" "key"
                                (list false? boolean? my-file-exists?)))))
  (backup-key opensmtpd-srs-backup-key
              (default #f)
              (sanitize (lambda (var)
                          (my/sanitize var "opensmtpd-srs" "backup-key"
                                       (list false? integer?
                                             my-file-exists?)))))
  ;; TODO the user could set the string to be "zebra", which would break
  ;; the config.
  (ttl-delay opensmtpd-srs-ttl-delay
             (default #f)
             (sanitize (lambda (var)
                         (my/sanitize var "opensmtpd-srs" "ttl-delay"
                                      (list false? string?))))))

(define-record-type* <opensmtpd-queue>
  opensmtpd-queue make-opensmtpd-queue
  opensmtpd-queue?
  (compression opensmtpd-queue-compression
               (default #f)
               (sanitize (lambda (var)
                           (my/sanitize var "opensmtpd-queue" "compression"
                                        (list boolean?)))))
  (encryption opensmtpd-queue-encryption
              (default #f)
              (sanitize (lambda (var)
                          (my/sanitize var "opensmtpd-queue" "encryption"
                                       (list boolean? string?
                                             my-file-exists?)))))
  ;; TODO the user could set the string to be "zebra", which would break
  ;; the config.
  (ttl-delay opensmtpd-queue-ttl-delay
             (default #f)
             (sanitize (lambda (var)
                         (my/sanitize var "opensmtpd-queue" "ttl-delay"
                                      (list false? string?))))))

(define-record-type* <opensmtpd-configuration>
  opensmtpd-configuration make-opensmtpd-configuration
  opensmtpd-configuration?
  (package opensmtpd-configuration-package
           (default opensmtpd))
  (config-file opensmtpd-configuration-config-file
               (default #f))
  ;; FIXME/TODO should I include a admd authservid entry?
  (bounce opensmtpd-configuration-bounce
          (default #f)
          (sanitize
           (lambda (var)
             (cond ((false? var)
                    var)
                   ((and (list? var)
                         (>= 4 (length var))
                         (<= 1 (length var))
                         (list-of-strings? var)
                         (every (lambda (str)
                                  (and (<= 2 (string-length str))
                                       ;; last character of str is 's' or 'm'
                                       ;; or 'h' or 'd'.
                                       (member (string-take-right str 1)
                                               (list "s" "m" "h" "d"))
                                       ;; first part of str is an integer.
                                       (integer?
                                        (string->number
                                         (string-take str
                                                      (- (string-length str)
                                                         1 ))))))
                                var))
                    var)
                   (else
                    ;; FIXME TODO I am getting a warning that says
                    ;; possibly wrong number of arguments to `G_'
                    ;; is one of the below lines to blame?
                    (if (string? var)
                        (report-error (G_ "(bounce \"~a\") is invalid.\n") var)
                        (report-error (G_ "(bounce ~a) is invalid.\n") var))
                    (display-hint (G_ "Try (bounce (list \"30m\" \"2h\"))\n"))
                    (throw 'bad! var))))))
  (cas opensmtpd-configuration-cas
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-configuration" "cas"
                                (list false? list-of-opensmtpd-ca?)))))

  ;; list of many records of type opensmtpd-interface
  (interfaces opensmtpd-configuration-interfaces
              (default (list (opensmtpd-interface)))
              (sanitize
               (lambda (var)
                 ;; This makes sure that no opensmtpd-interface is like this:
                 ;; (opensmtpd-interface (senders #f) (masquerade #t)), which
                 ;; is a syntax error.
                 (define (correct-senders? interface)
                   (not
                    (and (not (opensmtpd-interface-senders interface))
                         (opensmtpd-interface-masquerade interface))))

                 (define fieldname "interface")

                 ;; TODO rework this sanitize bit, so that if someone writes:
                 ;; (opensmtpd-interface (senders #f) (masquerade #t)), they
                 ;; get a proper error.
                 ;; (report-error
                 ;;  (G_ "((senders #f) & (masquerade #t)) is invalid.\n"))
                 (if (and (list-of-interface? var)
                          (every correct-senders? var)
                          (not (contains-duplicate? var)))
                     var
                     (begin
                       (display "<opensmtpd-configuration> fieldname ")
                       (display  "'interface' may be #f or a list of records")
                       (display "\n of unique <opensmtpd-interface>.\n")
                       (throw 'bad! var))))))
  (socket opensmtpd-configuration-socket
                    (default #f)
                    (sanitize
                     (lambda (var)
                       (define fieldname "socket")
                       (if (or (opensmtpd-socket? var)
                               (false? var))
                           var
                           (begin
                             (report-error (G_ "(~a \"~a\") is invalid.~%")
                                           fieldname var)
                             (display-hint
                              (G_
                               (string-append "Try an ("
                                              fieldname
                                              " (opensmtpd-socket ...)) .\n")))
                             (throw 'bad! var))))))
  ;; list of strings of absolute path names
  (includes opensmtpd-configuration-includes
            (default #f)
            (sanitize (lambda (var)
                        (my/sanitize var "opensmtpd-configuration" "includes"
                                     (list false? list-of-strings? gexp?)))))
  (matches opensmtpd-configuration-matches
           (default (list (opensmtpd-match
                           (action (opensmtpd-local-delivery
                                    (name "local")
                                    (method "mbox")))
                           (options (list
                                     (opensmtpd-option
                                      (option "for local")))))
                          (opensmtpd-match
                           (action (opensmtpd-relay
                                    (name "outbound")))
                           (options (list
                                     (opensmtpd-option
                                      (option "from local"))
                                     (opensmtpd-option
                                      (option "for any")))))))
           ;; TODO perhaps I should sanitize this function like I sanitized
           ;; the 'filters'. For example, you could have two different.
           ;; actions, one for local delivery and one for remote,
           ;; with the same name.
           ;; It might be a bit complicated to do this.
           ;; I might just let smtpd figure out if the user made a silly
           ;; mistake by having two different actions with the same name.
           (sanitize (lambda (var)
                       var
                       (my/sanitize var "opensmtpd-configuration" "matches"
                                    (list list-of-opensmtpd-match?)))))
  ;; list of many records of type mda-wrapper
  ;; TODO/FIXME support using gexps here
  ;; eg (list "name" gexp)
  ;; TODO what are mda-wrappers for?  How do I use this fieldname?
  ;; (mda-wrappers opensmtpd-configuration-mda-wrappers
  ;;               (default #f)
  ;;               (sanitize (lambda (var)
  ;;                           (my/sanitize var
  ;;                                        "opensmtpd-configuration"
  ;;                                        "mda-wrappers"
  ;;                                        (list false? string?)))))
  (mta-max-deferred opensmtpd-configuration-mta-max-deferred
                    (default 100)
                    (sanitize (lambda (var)
                                (my/sanitize var "opensmtpd-configuration"
                                             "mta-max-deferred"
                                             (list number?)))))
  (queue opensmtpd-configuration-queue
         (default #f)
         (sanitize (lambda (var)
                     (my/sanitize var "opensmtpd-configuration" "queue"
                                  (list false? opensmtpd-queue?)))))
  (smtp opensmtpd-configuration-smtp
        (default #f)
        (sanitize (lambda (var)
                    (my/sanitize var "opensmtpd-configuration" "smtp"
                                 (list false? opensmtpd-smtp?)))))
  (srs opensmtpd-configuration-srs
       (default #f)
       (sanitize (lambda (var)
                   (my/sanitize var "opensmtpd-configuration" "srs"
                                (list false? opensmtpd-srs?)))))
  (setgid-commands? opensmtpd-setgid-commands? (default #t)))

;; this help procedure is used 3 or 4 times by
;; sanitize-options-for-opensmtpd-match
(define* (throw-error-duplicate-option option error-arg
                                       #:key (record-name "match"))
  (throw-error error-arg
               (list
                (string-append "(opensmtpd-" record-name
                               ") (options ...)) can only have one \n"
                               "(opensmtpd-option (option \"" option
                               "\")) record, but more are present. \n"))
               #:duplicate-option #t))

;; this procedure sanitizes the fieldname opensmtpd-match-options
(define* (sanitize-options-for-opensmtpd-match %options)
  (define option-list (list "for any" "for local" "for domain"
                            "for rcpt-to" "from any" "from auth"
                            "from local" "from mail-from" "from rdns"
                            "from socket" "from src" "auth" "helo"
                            "mail-from" "rcpt-to" "tag" "tls"))
  (when (not (list-of-opensmtpd-option? %options))
    (report-error (G_ ""))
    (display
     (string-append "(opensmtpd-match (options ...)) is a list of unique"
                    " (opensmtpd-option ...) records.\nIt's value is: "))
    (display %options)
    (display "\n")
    (throw 'bad! %options))

  (let loop ((%traversing-options %options)
             ;; sanitized-options is an alist that may end of looking
             ;; like:
             ;; (("for" (opensmtpd-option (option "for any")))
             ;;  ("from" (opensmtpd-option (option "from any")))
             ;;  ("tag (opensmtpd-option (option "tag") (data "tag")))
             (%sanitized-options '())
             (option-record (if (null? %options)
                                '()
                                (car %options)))
             (option-string (if (null? %options)
                                '()
                                (opensmtpd-option-option
                                 (car %options)))))

    (cond
     ((null? %traversing-options)
      %options)
     ;; error if option-string is invalid option
     ((not (member option-string option-list))
      (report-error (G_ "(opensmtpd-match \"~a\")) is invalid.\n")
                    option-string)
      (display-hint (G_ ""))
      (display (hint-string option-string option-list #:fieldname "option"))
      (throw 'bad! option-string))
     ;; error, if duplicate option
     ((assoc-ref %sanitized-options option-string)
      (report-error (G_ ""))
      (display (string-append "(opensmtpd-match (options ...)) can "
                              "only have one (opensmtpd-option (option "
                              "\"" option-string "\")), but more "
                              " \n are present.\n"))
      (display-hint
       (format #f (G_ "Try removing one (opensmtpd-option (option \"~a\")).~%")
        option-string))
      (throw 'bad! option-record))
     ;; error, if duplicate from or duplicate for option
     ((or
       (if (and (string=? "for" (substring option-string 0 3))
                (assoc-ref %sanitized-options "for"))
           #t
           #f)
       (if (and (>= (length (string->list option-string)) 4)
                (string=? "from" (substring option-string 0 4))
                (assoc-ref %sanitized-options "from"))
           #t
           #f))
      (throw-error %options
                   (list "(opensmtpd-match (options ...)) can only have one"
                         " (option \"for ...\") and one (option \"from ...\")"
                         "\nBut (option \"" option-string "\") and (option \""
                         (opensmtpd-option-option
                          (if (assoc-ref %sanitized-options "for")
                              (assoc-ref %sanitized-options "for")
                              (assoc-ref %sanitized-options "from")))
                         "\") are present.\n")
                   #:hint-strings
                   (list "Try removing one "
                         (if (string=? "for" (substring option-string 0 3))
                             "(opensmtpd-option (option \"for ...\"))"
                             "(opensmtpd-option (option \"from ...\"))")
                         " record.\n")))
     ;; these 3 options must have fieldname data defined.
     ((and (member option-string
                   (list "helo" "mail-from" "rcpt-to"))
           (not (opensmtpd-option-data option-record)))
      (report-error (G_ ""))
      (display (string-append "(option \"" option-string
                              "\") must have (data ...) of type string or an "
                              "(opensmtpd-table ...) record.\n"))
      (throw 'bad! option-string))
     ;; fieldname data must be a string.
     ((and (string=? "tag" option-string)
           (not (string? (opensmtpd-option-data option-record))))
      (throw-error option-record
                   (list "(opensmtpd-match ... (option \"tag\"))"
                         " must have a 'data' of type string.\n")))
     ((or (string=? "tls" option-string)
          (string=? "for" (substring option-string 0 3))
          (string=? "from" (substring option-string 0 4)))
      ;; let's test the "for" and "from" options now.
      (cond
       ;; the options in this list cannot define 'data' or 'regex'
       ;; fieldnames.
       ((and (member option-string (list "for local" "for any"
                                         "from any" "from local"
                                         "from socket" "tls"))
             (or (opensmtpd-option-data option-record)
                 (opensmtpd-option-regex option-record)))
        (report-error (G_ ""))
        (display (string-append "When (openmstpd-option (option \""
                                option-string "\") ...), "
                                "then (data ...) and (regex ...) "
                                "must be #f. \n"))
        (throw 'bad! option-record))
       ;; the options in this list must have a data field of type
       ;; string or tables-data-are-a-list-of-strings?
       ((and (member option-string
                     (list "for domain" "for rcpt-to"
                           "from mail-from" "from src"))
             (or (false? (opensmtpd-option-data option-record))
                 (tables-data-are-assoc-list?
                  (opensmtpd-option-data option-record))))
        (throw-error option-record
                     (list "When (openmstpd-option (option \""
                           option-string "\") ...) \n"
                           "then (data ...) must be a string or an \n"
                           "(opensmtpd-table ....) record whose "
                           "'data' is a list of strings.\n")))
       (else
        (loop (cdr %traversing-options)
              (alist-cons
               (cond ((string=? "for" (substring option-string 0 3))
                      "for")
                     ((string=? "tls" option-string)
                      "tls")
                     (else "from"))
               option-record
               %sanitized-options)
              ;;option-record
              (if (null? (cdr %traversing-options))
                  '()
                  (car (cdr %traversing-options)))
              ;; option-string
              (if (null? (cdr %traversing-options))
                  '()
                  (opensmtpd-option-option
                   (car (cdr %traversing-options))))))))
     ;; TODO if auth's 'data' is an assoc-list table, then
     ;; it IS invalid!
     ;; option-string = 'auth' cannot be made invalidly,
     ;; do not test for it.
     (else
      (loop (cdr %traversing-options)
            (alist-cons option-string option-record
                        %sanitized-options)
            ;;option-record
            (if (null? (cdr %traversing-options))
                '()
                (car (cdr %traversing-options)))
            ;; option-string
            (if (null? (cdr %traversing-options))
                '()
                (opensmtpd-option-option
                 (car (cdr %traversing-options)))))))))

(define (filter-phase-has-message-and-value? record)
  (and (opensmtpd-filter-phase-message record)
       (opensmtpd-filter-phase-value record)))

;; return #t if phase needs a message. Or if the message did not start
;; with a 4xx or 5xx status code. otherwise #f
(define (filter-phase-decision-lacks-proper-message? record)
  (define decision (opensmtpd-filter-phase-decision record))
  (if (member decision (list "disconnect" "reject"))
      ;; this message needs to be RFC compliant, meaning
      ;; that it need to start with 4xx or 5xx status code
      (cond ((eq? #f (opensmtpd-filter-phase-message record))
             #t)
            ((string? (opensmtpd-filter-phase-message record))
             (let ((number (string->number
                            (substring
                             (opensmtpd-filter-phase-message record) 0 3))))
               (if (and (number? number)
                        (and (< number 600) (> number 399)))
                   #f
                   #t))))
      #f))

;; 'decision' "rewrite" requires 'value' to be a number.
(define (filter-phase-lacks-proper-value? record)
  (define decision (opensmtpd-filter-phase-decision record))
  (if (string=? "rewrite" decision)
      (if (and (number? (opensmtpd-filter-phase-value record))
               (eq? #f (opensmtpd-filter-phase-message record)))
          #f
          #t)
      #f))

;; 'decision' "junk" or "bypass" cannot have a message or a value.
(define (filter-phase-has-incorrect-junk-or-bypass? record)
  (and
   (member
    (opensmtpd-filter-phase-decision record)
    (list "junk" "bypass"))
   (or
    (opensmtpd-filter-phase-value record)
    (opensmtpd-filter-phase-message record))))

(define (filter-phase-junks-after-commit? record)
  (and (string=? "junk" (opensmtpd-filter-phase-decision record))
       (string=? "commit" (opensmtpd-filter-phase-phase record))))

;; returns #t if list is a unique list of <opensmtpd-filter> or
;; <opensmtpd-filter-phase> returns # otherwise
;; only opensmtpd-filter-chain? uses this function, and opensmtpd-filter-chain
;; is NEVER actually used.
;; I could possibly remove it.
(define (list-of-unique-filter-or-filter-phase? %filters)
  (and (list? %filters)
       (not (null? %filters))
       ;; this list is made up of only <opensmtpd-filter-phase>
       ;; or <opensmtpd-filter>
       (every (lambda (filter)
                (or (opensmtpd-filter? filter)
                    (opensmtpd-filter-phase? filter)))
              %filters)
       ;; each filter-name is unique.
       (not (duplicate-filter-name %filters))))

(define (filters->list-of-filter-names %filters)
  (map (lambda (filter)
         (cond ((opensmtpd-filter-phase? filter)
                (opensmtpd-filter-phase-name filter))
               (else (opensmtpd-filter-name filter))))
       %filters))

(define (duplicate-string-in-list strings)
  (define first-string (car strings))
  (cond ((null? (cdr strings))
         #f)
        ((any (lambda (element)
                (if (string=? element first-string)
                    element
                    #f))
              (cdr strings))
         first-string)
        (else (duplicate-string-in-list (cdr strings)))))

(define (duplicate-filter-name %filters)
  (define filter-names (filters->list-of-filter-names %filters))
  (duplicate-string-in-list filter-names))

;; the sanitize procedures used for sanitizing each <opensmtpd-interface> and
;; <opensmtpd-socket> fieldname 'filters'.
;; It primarily sanitizes <filter-phases>.  The only sanitization it does
;; for <filter>s, is no make sure there are no duplicate filter names.

(define* (sanitize-socket-and-interfaces-filters
          %filters
          #:key (socket-or-interface "interface"))

  ;; if there are two filters with the same name, store that name here.
  (define the-duplicate-filter-name
    (if (not %filters)
        #f
        (duplicate-filter-name %filters)))

  (define %filter-phases
    (if (not %filters)
        '()
        (remove opensmtpd-filter? %filters)))
  ;; the order of the first two tests in this cond is important.
  ;; (false?) has to be 1st and (duplicate-filter-filter-name) has to be
  ;; second. You may optionally re-order the other alternates in the cond.
  (cond ((false? %filters)
         #f)
        (the-duplicate-filter-name
         (report-error (G_ ""))
         (display (string-append
                   "(opensmtpd-" socket-or-interface
                   " (filters ...)) has a duplicate filter name: \""
                   the-duplicate-filter-name "\".\n"))
         (throw 'bad! %filters))
        (else
         (let loop ((%traversing-list %filter-phases)
                    (fieldname (if (null? %filter-phases)
                                   '()
                                   (opensmtpd-filter-phase-decision
                                    (car %filter-phases)))))
           (cond
            ((null? %traversing-list)
             %filters)
            ((opensmtpd-filter? (car %traversing-list))
             (loop (cdr %traversing-list)
                   (if (null? (cdr %traversing-list))
                       '()
                       (opensmtpd-filter-phase-decision
                        (car (cdr %traversing-list))))))
            ((filter-phase-has-message-and-value?
              (car %traversing-list))
             (report-error (G_ ""))
             (display
              (string-append "(opensmtpd-filter-phase ...) cannot define "
                             "fieldnames 'value' \n and 'message'.\n")))
            ((filter-phase-decision-lacks-proper-message?
              (car %traversing-list))
             (cond
              ((string? fieldname)
               (report-error
                (G_ "(decision \"~a\") with (message ...) is invalid.~%")
                fieldname))
              ((or (integer? fieldname) (boolean? fieldname))
               (report-error
                (G_ "(decision ~a) with (message ...) is invalid.~%")
                fieldname))
              (else
               (report-error
                (G_ "(~a ...\") with (message ...) is invalid.~%... is ~a")
                fieldname)))
             (display-hint
              (G_ (string-append "Try (opensmtpd-filter-phase "
                                 "(message \"406 Not acceptable.\") "
                                 "(decision \"" fieldname "\")).\n")))
             (throw 'bad! (car %traversing-list)))
            ((filter-phase-lacks-proper-value? (car %traversing-list))
             (begin
               (report-error (G_ ""))
               (display
                (string-append
                 "(opensmtpd-filter-phase (decision \"rewrite\")"
                 "\n\t\t(value ...)) must be a number.\n"))
               (display-hint (G_ "Try (value 5)."))
               (throw 'bad! (car %traversing-list))))
            ((filter-phase-has-incorrect-junk-or-bypass?
              (car %traversing-list))
             (begin
               (report-error (G_ ""))
               (display
                (string-append "(opensmtpd-filter-phase (decision \""
                               (opensmtpd-filter-phase-decision
                                (car %traversing-list))
                               "\") cannot define (message ...) or "
                               "(value ...).\n"))
               (throw 'bad! (car %traversing-list))))
            ((filter-phase-junks-after-commit? (car %traversing-list))
             (begin
               (report-error (G_ ""))
               (display
                (string-append
                 "(opensmtpd-filter-phase (decision \"junk\")\n\t\t "
                 "(phase \"commit\")) is invalid.\n"))
               (display-hint
                (G_ (string-append "You cannot junk an email during phase "
                                   "\"commit\". Try (phase \"data\").\n")))
               (throw 'bad! (car %traversing-list))))
            (else (loop (cdr %traversing-list)
                        (if (null? (cdr %traversing-list))
                            '()
                            (opensmtpd-filter-phase-decision
                             (car (cdr %traversing-list)))))))))))

(define* (sanitize-options-for-filter-phase %options)
  (define option-list
    (list "fcrdns" "rdns" "src" "helo" "auth" "mail-from" "rcpt-to"))
  (let loop ((%traversing-options %options)
             ;; sanitized-options is an alist that may end of looking like:
             ;; (("fcrdns" (opensmtpd-option (option "fcrdns")))
             ;;  ("auth" (opensmtpd-option (option "auth"))))
             (%sanitized-options '())
             (option-record (if (null? %options)
                                '()
                                (car %options)))
             (option-string (if (null? %options)
                                '()
                                (opensmtpd-option-option (car %options)))))
    (cond
     ((null? %traversing-options)
      %options)
     ;; error if option-string is invalid option
     ((not (member option-string option-list))
      (report-error
       (G_ "(opensmtpd-filter-phase (option \"~a\")) is invalid.\n")
       option-string)
      (display-hint (G_ ""))
      (display (hint-string option-string option-list
                            #:fieldname "option"))
      (throw 'bad! option-string))

     ;; if we see two "rdns" (for example), throw a
     ;; "duplicate option" error.
     ((assoc-ref %sanitized-options option-string)
      (report-error (G_ ""))
      (display (string-append "(opensmtpd-filter-phase (options ...)) can "
                              "only have one\n (opensmtpd-option (option \""
                              option-string "\")), but more are present.\n"))
      (display-hint
       (format #f (G_ "Try removing one (option \"~a\").~%") option-string))
      (throw 'bad! option-record))

     ;; the next 4 options must have fieldname 'data' defined.
     ((and (member option-string
                   (list "src" "helo" "mail-from" "rcpt-to"))
           (not (opensmtpd-table? (opensmtpd-option-data option-record))))
      (report-error (G_ ""))
      (display (string-append "(opensmtpd-filter-phase ... " "(option \""
                              option-string "\")) must define (data ...).\n"))
      (display-hint (G_ "Try defining (data (opensmtpd-table ...).\n"))
      (throw 'bad! option-record))
     ;;fcrdns cannot have fieldname data defined
     ((and (string=? "fcrdns" option-string)
           (opensmtpd-option-data option-record))
      (report-error (G_ ""))
      (display (string-append "(opensmtpd-option \"" option-string "\") "
                              "cannot define (data ...).\n"))
      (display-hint (G_ ""))
      (display "Try removing (data ...).\n")
      (throw 'bad! option-record))
     ;; rdns and auth cannot be made invalidly.
     ;; skip testing them.
     (else (loop (cdr %traversing-options)
                 (alist-cons option-string option-record
                             %sanitized-options)
                 ;; option-record
                 (if (null? (cdr %traversing-options))
                     '()
                     (car (cdr %traversing-options)))
                 ;; option-string
                 (if (null? (cdr %traversing-options))
                     '()
                     (opensmtpd-option-option
                      (car (cdr %traversing-options)))))))))

(define* (throw-error var %strings
                      #:key
                      (record-name #f)
                      (duplicate-option #f)
                      (fieldname #f)
                      (hint-strings #f))
  (cond ((and record-name fieldname)
         (cond ((or (string? var))
                (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var))
               ((boolean? var)
                (report-error (G_ "(~a ~a) is invalid.~%") fieldname var))
               ((number? var)
                (report-error (G_ "(~a ~a) is invalid.~%") fieldname
                              (number->string var)))
               (else
                (report-error (G_ "(~a ...) is invalid.~%Its value is: ~a~%")
                              fieldname var)))
         (display-hint (G_ (string-append "(opensmtpd-" record-name
                                          " (fieldname " fieldname "...)) "
                                          (apply string-append %strings))))
         (throw 'bad! var))
        ((list? hint-strings)
         (report-error (G_ ""))
         (display (apply string-append %strings))
         (display-hint (G_ (apply string-append hint-strings)))
         (throw 'bad! var))
        ;; display the output for throw-error-duplicate-option
        (duplicate-option
         (report-error (G_ ""))
         (display (apply string-append %strings))
         (display-hint
          (format #f
                  (G_ "Try removing one (opensmtpd-option \"~a\") option.\n")
                               var))
         (throw 'bad! var))
        (else
         (report-error (G_ ""))
         (display (apply string-append %strings))
         (throw 'bad! var))))

;; if strings is (list "auth" "for any" "from local")
;; Then this will return "Try \"auth\", \"for any\", or \"from local\".
(define (try-string strings)
  (string-append "Try "
                 (let loop ((strings strings))
                   (cond ((= 1 (length strings))
                          (string-append
                           "or \"" (car strings) "\".\n"))
                         (else
                          (string-append
                           "\"" (car strings) "\", "
                           (loop (cdr strings))))))))

;; suppose string is "for anys"
;; and strings is (list "for any" "for local" "for domain")
;; then hint-string will return "Did you mean "for any"?"
(define* (hint-string string strings
                      #:key (fieldname #f))
  (define str (string-closest string strings))
  (if (not str)
      (try-string strings)
      (if fieldname
          (string-append "Did you mean (" fieldname " \""
                         str "\") ?\n")
          (string-append "Did you mean  \"" str "\" ?\n"))))

;; this is used for sanitizing <opensmtpd-filter-phase> fieldname 'options'
(define (contains-duplicate? list)
  (if (null? list)
      #f
      (or
      ;; check if (car list) is in (cdr list)
      (any (lambda (var)
             (equal? var (car list)))
           (cdr list))
       ;; check if (cdr list) contains duplicate
       (contains-duplicate? (cdr list)))))

(define* (variable->string var #:key (append "") (postpend " "))
  (let ((var (if (number? var)
                 (number->string var)
                 var)))
    (if var
        (string-append append var postpend)
        "")))

;;; Various functions to check that lists are of the appropriate type.

;; given a list and procedure, this tests that each element of list is of type
;; ie: (list-of-type? list string?) tests each list is of type string.
(define (list-of-type? list proc?)
  (if (and (list? list)
           (not (null? list)))
      (let loop ((list list))
        (if (null? list)
            #t
            (if (proc? (car list))
                (loop (cdr list))
                #f)))
      #f))

(define (list-of-strings? list)
  (list-of-type? list string?))

(define (list-of-interface? list)
  (list-of-type? list opensmtpd-interface?))

(define (list-of-opensmtpd-option? list)
  (list-of-type?
   list opensmtpd-option?))

(define (list-of-opensmtpd-ca? list)
  (list-of-type? list opensmtpd-ca?))

(define (list-of-opensmtpd-pki? list)
  (list-of-type? list opensmtpd-pki?))

(define (list-of-opensmtpd-match? list)
  (list-of-type? list opensmtpd-match?))

(define* (list-of-strings->string list
                                  #:key
                                  (string-delimiter ", ")
                                  (postpend "")
                                  (append "")
                                  (drop-right-number 2))
  (string-drop-right
   (string-append (let loop ((list list))
                    (if (null? list)
                        ""
                        (string-append append (car list) postpend
                                       string-delimiter
                                       (loop (cdr list)))))
                  append)
   drop-right-number))

;; TODO I should probably change this to alist, because that's what this is.
(define (assoc-list? assoc-list)
  (list-of-type? assoc-list
                 (lambda (pair)
                   (and (pair? pair)
                        (string? (car pair))
                        (string? (cdr pair))
                        (<= 1 (string-length (car pair)))
                        (<= 1 (string-length (cdr pair)))))))

(define (nested-list? list)
  (every (lambda (element)
           (and
            (list-of-strings? element)
            (< 1 (length element))))
         list))

;; this procedure takes in one argument.
;; if that argument is an <opensmtpd-table> whose fieldname 'values' is
;; an assoc-list, then it returns #t, #f if otherwise.
(define (tables-data-are-assoc-list? table)
  (if (not (opensmtpd-table? table))
      #f
      (assoc-list? (opensmtpd-table-data table))))

;; this procedure takes in one argument
;; if that argument is an <opensmtpd-table> whose fieldname 'values' is a
;; list of strings, then it returns #t, #f if otherwise.
(define (tables-data-are-a-list-of-strings? table)
  (if (not (opensmtpd-table? table))
      #f
      (and (list-of-strings? (opensmtpd-table-data table)))))

;; This procedures takes in an <opensmtpd-table>
;; if that table a list of lists of strings eg:
;; (list (list "cat") (list "dog"))
;; then this returns #t, otherwise false.
(define (tables-data-are-a-nested-list-of-strings? table)
  (cond ((false? (opensmtpd-table-data table))
         #f)
        ((not (list? (opensmtpd-table-data table)))
         #f)
        (else
         (nested-list? (opensmtpd-table-data table)))))

;;; The following functions convert various records into strings.

;; these next few functions help me to turn <table>s
;; into strings suitable to fit into "opensmtpd.conf".
(define (assoc-list->string assoc-list)
  (string-drop-right
   (let loop ((assoc-list assoc-list))
     (if (null? assoc-list)
         ""
         ;; pair is (cons "hello" "world") -> ("hello" . "world")
         (let ((pair (car assoc-list)))
           (string-append
            "\"" (car pair)  "\""
            " = "
            "\"" (cdr pair) "\""
            ", "
            (loop (cdr assoc-list))))))
   2))

;; can be of type: (quote list-of-strings) or (quote assoc-list)
;;  this will output a string that looks like:
;;  table <"mytable"> { "ludo"="ludo@gnu.org" }
(define (opensmtpd-table->string table)
  (string-append "table \"" (opensmtpd-table-name table) "\" "
                 (cond ((tables-data-are-a-list-of-strings? table)
                        (string-append "{ "
                                       (list-of-strings->string
                                        (opensmtpd-table-data table)
                                        #:append "\""
                                        #:drop-right-number 3
                                        #:postpend "\"") " }"))
                       ((tables-data-are-assoc-list? table)
                        (string-append "{ "
                                       (assoc-list->string
                                        (opensmtpd-table-data table)) " }"))
                       (else (throw 'youMessedUp table)))
                 " \n"))

;; will output something like:
;; <"mytable">
(define (opensmtpd-table-name->string table)
  (string-append "<\"" (opensmtpd-table-name table) "\">"))

(define (opensmtpd-interface->string record)
  (string-append
   "listen on "
   (opensmtpd-interface-interface record) " "
   (let* ((hostname (opensmtpd-interface-hostname record))
          (hostnames (if (opensmtpd-interface-hostnames record)
                         (opensmtpd-table-name
                          (opensmtpd-interface-hostnames record))
                         #f))
          (filters (opensmtpd-interface-filters record))
          (filter-name (if filters
                           (if (< 1 (length filters))
                               (generate-filter-chain-name filters)
                               (if (opensmtpd-filter? (car filters))
                                   (opensmtpd-filter-name (car filters))
                                   (opensmtpd-filter-phase-name
                                    (car filters))))
                           #f))
          (mask-src (opensmtpd-interface-mask-src record))
          (tag (opensmtpd-interface-tag record))
          (senders (opensmtpd-interface-senders record))
          (masquerade (opensmtpd-interface-masquerade record))
          (secure-connection (opensmtpd-interface-secure-connection record))
          (port (opensmtpd-interface-port record))
          (pki (opensmtpd-interface-pki record))
          (auth (opensmtpd-interface-auth record))
          (auth-optional (opensmtpd-interface-auth-optional record)))
     (string-append
      (if mask-src
          (string-append "mask-src ")
          "")
      (variable->string hostname #:append "hostname ")
      (variable->string hostnames #:append "hostnames <" #:postpend "> ")
      (variable->string filter-name #:append "filter \"" #:postpend "\" ")
      (variable->string tag #:append "tag \"" #:postpend "\" ")
      (if secure-connection
          (cond ((string=? "smtps" secure-connection)
                 "smtps ")
                ((string=? "tls" secure-connection)
                 "tls ")
                ((string=? "tls-require" secure-connection)
                 "tls-require ")
                ((string=? "tls-require-verify" secure-connection)
                 "tls-require verify "))
          "")
      (if senders
          (string-append "senders <\"" (opensmtpd-table-name senders) "\"> "
           (if masquerade
               "masquerade "
               ""))
          "")
      (variable->string port #:append "port " #:postpend " ")
      (if pki
          (variable->string (opensmtpd-pki-domain pki) #:append "pki ")
          "")
      (if auth
          (string-append "auth "
                         (if (opensmtpd-table? auth)
                             (string-append
                              (opensmtpd-table-name->string auth))
                             ""))
          "")
      (if auth-optional
          (string-append "auth-optional "
                         (if (opensmtpd-table? auth-optional)
                             (string-append
                              "<\""
                              (opensmtpd-table-name->string auth-optional)
                              "\">")
                             ""))
          "")
      "\n"))))

(define (opensmtpd-socket->string record)
  (string-append
   "listen on socket "
   (let* ((filters (opensmtpd-socket-filters record))
          (filter-name (if filters
                           (if (< 1 (length filters))
                               (generate-filter-chain-name filters)
                               (if (opensmtpd-filter? (car filters))
                                   (opensmtpd-filter-name (car filters))
                                   (opensmtpd-filter-phase-name
                                    (car filters))))
                           #f))
          (mask-src (opensmtpd-socket-mask-src record))
          (tag (opensmtpd-socket-tag record)))
     (string-append
      (if mask-src
          (string-append "mask-src ")
          "")
      (variable->string filter-name #:append "filter \"" #:postpend "\" ")
      (variable->string tag #:append "tag \"" #:postpend "\" ")
      "\n"))))

(define (opensmtpd-relay->string record)
  (let ((backup (opensmtpd-relay-backup record))
        (backup-mx (opensmtpd-relay-backup-mx record))
        (helo (opensmtpd-relay-helo record))
        ;; helo-src can either be a string IP address or an <opensmtpd-table>
        (helo-src (if (opensmtpd-relay-helo-src record)
                      (if (string? (opensmtpd-relay-helo-src record))
                          (opensmtpd-relay-helo-src record)
                          (string-append "<\""
                                         (opensmtpd-table-name
                                          (opensmtpd-relay-src record))
                                         "\">"))
                      #f))
        (domain (if (opensmtpd-relay-domain record)
                    (opensmtpd-table-name
                     (opensmtpd-relay-domain record))
                    #f))
        (host (opensmtpd-relay-host record))
        (name (opensmtpd-relay-name record))
        (pki (if (opensmtpd-relay-pki record)
                 (opensmtpd-pki-domain (opensmtpd-relay-pki record))
                 #f))
        (srs (opensmtpd-relay-srs record))
        (tls (opensmtpd-relay-tls record))
        (auth (if (opensmtpd-relay-auth record)
                  (opensmtpd-table-name
                   (opensmtpd-relay-auth record))
                  #f))
        (mail-from (opensmtpd-relay-mail-from record))
        ;; src can either be a string IP address or an <opensmtpd-table>
        (src (if (opensmtpd-relay-src record)
                 (if (string? (opensmtpd-relay-src record))
                     (opensmtpd-relay-src record)
                     (string-append "<\""
                                    (opensmtpd-table-name
                                     (opensmtpd-relay-src record))
                                    "\">"))
                 #f)))

    (string-append
     "\""
     name
     "\" " "relay "
     ;;FIXME should I always quote the host fieldname?
     ;; do I need to quote localhost via "localhost" ?
     (variable->string host #:append "host \"" #:postpend "\" ")
     (variable->string backup)
     (variable->string backup-mx #:append "backup mx ")
     (variable->string helo #:append "helo ")
     (variable->string helo-src #:append "helo-src ")
     (variable->string domain #:append "domain <\"" #:postpend "\"> ")
     (variable->string host #:append "host ")
     (variable->string pki #:append "pki ")
     (variable->string srs)
     (variable->string tls #:append "tls ")
     (variable->string auth #:append "auth <\"" #:postpend "\"> ")
     (variable->string mail-from #:append "mail-from ")
     (variable->string src #:append "src ")
     "\n")))

(define (opensmtpd-lmtp->string record)
  (string-append "lmtp "
                 (opensmtpd-lmtp-destination record)
                 (if (opensmtpd-lmtp-rcpt-to record)
                     (begin
                       " " (opensmtpd-lmtp-rcpt-to record))
                     "")))

(define (opensmtpd-mda->string record)
  (string-append "mda "
                 (opensmtpd-mda-command record) " "))

(define (opensmtpd-maildir->string record)
  (string-append "maildir "
                 "\""
                 (if (opensmtpd-maildir-pathname record)
                     (opensmtpd-maildir-pathname record)
                     "~/Maildir")
                 "\""
                 (if (opensmtpd-maildir-junk record)
                     " junk "
                     " ")))

(define (opensmtpd-local-delivery->string record)
  (let ((name (opensmtpd-local-delivery-name record))
        (method (opensmtpd-local-delivery-method record))
        (alias (if (opensmtpd-local-delivery-alias record)
                   (opensmtpd-table-name
                    (opensmtpd-local-delivery-alias record))
                   #f))
        (ttl (opensmtpd-local-delivery-ttl record))
        (user (opensmtpd-local-delivery-user record))
        (userbase (if (opensmtpd-local-delivery-userbase record)
                      (opensmtpd-table-name
                       (opensmtpd-local-delivery-userbase record))
                      #f))
        (virtual (if (opensmtpd-local-delivery-virtual record)
                     (opensmtpd-table-name
                      (opensmtpd-local-delivery-virtual record))
                     #f))
        (wrapper (opensmtpd-local-delivery-wrapper record)))
    (string-append
     "\"" name "\" "
     (cond ((string? method)
            (string-append method " "))
           ((opensmtpd-mda? method)
            (opensmtpd-mda->string method))
           ((opensmtpd-lmtp? method)
            (opensmtpd-lmtp->string method))
           ((opensmtpd-maildir? method)
            (opensmtpd-maildir->string method)))
     ;; FIXME/TODO support specifying alias file:/path/to/alias-file  ?
     ;; I do not think that is something that I can do...
     (variable->string alias #:append "alias <\"" #:postpend "\"> ")
     (variable->string ttl #:append "ttl ")
     (variable->string user #:append "user ")
     (variable->string userbase #:append "userbase <\"" #:postpend "\"> ")
     (variable->string virtual #:append "virtual <\"" #:postpend "\"> ")
     (variable->string wrapper #:append "wrapper "))))

;; this function turns both opensmtpd-local-delivery and
;; opensmtpd-relay into strings.
(define (opensmtpd-action->string record)
  (string-append "action "
                 (cond ((opensmtpd-local-delivery? record)
                        (opensmtpd-local-delivery->string record))
                       ((opensmtpd-relay? record)
                        (opensmtpd-relay->string record)))
                 " \n"))

;; this turns option records found in <opensmtpd-match> into strings.
(define* (opensmtpd-option->string record
                                                 #:key
                                                 (space-after-! #f))
  (let ((bool (opensmtpd-option-bool record))
        (option (opensmtpd-option-option record))
        (regex (opensmtpd-option-regex record))
        (data (opensmtpd-option-data record)))
    (string-append
     (if (false? bool)
         (if space-after-!
             "! "
             "!")
         "")
     option " "
     (if regex
         "regex "
         "")
     (if data
         (if (opensmtpd-table? data)
             (string-append
              (opensmtpd-table-name->string data) " ")
             (string-append data " "))
         ""))))

(define (opensmtpd-match->string record)
  (string-append "match "
                 (let* ((action (opensmtpd-match-action record))
                        (name (cond ((opensmtpd-relay? action)
                                     (opensmtpd-relay-name action))
                                    ((opensmtpd-local-delivery? action)
                                     (opensmtpd-local-delivery-name action))
                                    (else 'reject)))
                        (options (opensmtpd-match-options record)))
                   (string-append
                    (if options
                        (apply string-append
                               (map opensmtpd-option->string options))
                        "")
                    (if (string? name)
                        (string-append "action " "\"" name "\" ")
                        "reject ")
                    "\n"))))

(define (opensmtpd-ca->string record)
  (string-append "ca " (opensmtpd-ca-name record) " "
                 "cert \"" (opensmtpd-ca-file record) "\"\n"))

(define (opensmtpd-pki->string record)
  (let ((domain (opensmtpd-pki-domain record))
        (cert (opensmtpd-pki-cert record))
        (key (opensmtpd-pki-key record))
        (dhe (opensmtpd-pki-dhe record)))
    (string-append "pki " domain " " "cert \"" cert "\" \n"
                   "pki " domain " " "key \"" key "\" \n"
                   (if dhe
                       (string-append
                        "pki " domain " " "dhe " dhe "\n")
                       ""))))

(define (generate-filter-chain-name list-of-filters)
  (string-drop-right (apply string-append
                            (flatten
                             (map (lambda (filter)
                                    (list
                                     (if (opensmtpd-filter? filter)
                                         (opensmtpd-filter-name filter)
                                         (opensmtpd-filter-phase-name filter))
                                     "-"))
                                  list-of-filters)))
                     1))

(define (opensmtpd-filter->list-of-strings-and-gexps record)
  (list "filter "
        "\"" (opensmtpd-filter-name record) "\" "
        (if (opensmtpd-filter-exec record)
            "proc-exec "
            "proc ")
        "\"" (opensmtpd-filter-proc record) "\""
        "\n\n"))

;; this procedure takes in a list of <opensmtpd-filter> and
;; <opensmtpd-filter-phase>. It returns a string of the form:
;; filter "uniqueName" chain chain { "filter-name", "filter-name2" [, ...]}
(define (opensmtpd-filter-chain->string list-of-filters)
  (string-append "filter \""
                 (generate-filter-chain-name list-of-filters)
                 "\" "
                 "chain {"
                 (string-drop-right
                  (apply string-append
                         (flatten
                          (map (lambda (filter)
                                 (list
                                  "\""
                                  (if (opensmtpd-filter? filter)
                                      (opensmtpd-filter-name filter)
                                      (opensmtpd-filter-phase-name filter))
                                  "\", "))
                               list-of-filters)))
                  2)
                 "}\n\n"))

(define (opensmtpd-filter-phase->string record)
  (let ((name (opensmtpd-filter-phase-name record))
        (phase (opensmtpd-filter-phase-phase record))
        (decision (opensmtpd-filter-phase-decision record))
        (options (opensmtpd-filter-phase-options record))
        (message (opensmtpd-filter-phase-message record))
        (value (opensmtpd-filter-phase-value record)))
    (string-append "filter "
                   "\"" name "\" "
                   "phase " phase " "
                   "match "
                   (apply string-append ; turn the options into a string
                          (flatten
                           (map (lambda (option)
                                  (opensmtpd-option->string
                                   option #:space-after-! #f))
                                options)))
                   " "
                   decision " "
                   (if (member decision (list "reject" "disconnect"))
                       (string-append "\"" message "\"")
                       "")
                   (if (string=? "rewrite" decision)
                       (string-append "rewrite " (number->string value))
                       "")
                   "\n\n")))

;; in the next procedure, the variable 'filters' is a list of
;; <opensmtpd-filter>, <opensmtpd-filter-phase>, and filter chains, which are
;; lists that look like:
;; (list (opensmtpd-filter ...) (opensmtpd-filter-phase ...)
;;       (opensmtpd-filter-phase ...) (opensmtpd-filter ...))
;; This function converts (get-opensmtpd-filters <opensmtpd-configuration>)
;; to a string.
;; Consider if a user passed in a valid <opensmtpd-configuration>,
;; so that (get-opensmtpd-filters (opensmtpd-configuration)) returns
;; (list (opensmtpd-filter
;;         (name "rspamd")
;;         (proc "rspamd"))
;;       ;; this is a listen-on, with a filter-chain.
;;       (list (opensmtpd-filter-phase
;;               (name "dkimsign")
;;               ...)
;;               (opensmtpd-filter
;;                 (name "rspamd")
;;                 (proc "rspamd"))))
;;
;; (we will call the above list "total filters"):
;; did you notice that filter "rspamd" is listed twice?  Once by itself, and
;; once again in a filter chain. How do you make sure that it is NOT printed
;; twice in smtpd.conf?
;; 1st flatten "total filters", then remove its duplicates so that we
;; may print the <opensmtpd-filter>s and <opensmtpd-filter-phase>s.
;; 2nd now we go through "total filters", and we only print the filter-chains.
(define (opensmtpd-filters->list-of-strings-and-gexps filters)
  ;; first print the unique <opensmtpd-filter-phase>s and <opensmtpd-filter>s.
  ;; then print the filter-chains.
  ;; to do this: flatten filters, then remove duplicates.
  (flatten
   (list
    ;; TODO for funsies, try to figure out how to list the filter-phases and
    ;; filters in one go.  I tried it earlier, and it broke the service.
    ;; Why?
    ;;

    ;; print the filter-phases
    (apply string-append
           (map (lambda (filter)
                  (cond ((opensmtpd-filter-phase? filter)
                         (opensmtpd-filter-phase->string filter))
                        (else "")))
                (delete-duplicates (flatten filters))))

    ;; list the filters that may be gexps
    (map (lambda (filter)
           (cond ((opensmtpd-filter? filter)
                  (opensmtpd-filter->list-of-strings-and-gexps filter))
                 (else "")))
         (delete-duplicates (flatten filters)))

     ;; now we have to print the filter chains.
    (apply string-append
           (map (lambda (filter)
                  (cond ((list? filter)
                         (opensmtpd-filter-chain->string filter))
                        (else            ; you are a <opensmtpd-filter>
                         "")))
                filters)))))

(define (opensmtpd-configuration-includes->string string)
  (string-append
   "include \"" string "\"\n"))

(define (opensmtpd-configuration-srs->string record)
  (let ((key (opensmtpd-srs-key record))
        (backup-key (opensmtpd-srs-backup-key record))
        (ttl-delay (opensmtpd-srs-ttl-delay record)))
    (string-append
     (variable->string key #:append "srs key " #:postpend "\n")
     (variable->string backup-key #:append "srs key backup " #:postpend "\n")
     (variable->string ttl-delay #:append "srs ttl " #:postpend "\n")
     "\n")))

;; TODO make sure all options here work!  I just fixed limit-max-rcpt!
(define (opensmtpd-smtp->string record)
  (let ((ciphers (opensmtpd-smtp-ciphers record))
        (limit-max-mails (opensmtpd-smtp-limit-max-mails record))
        (limit-max-rcpt (opensmtpd-smtp-limit-max-rcpt record))
        (max-message-size (opensmtpd-smtp-max-message-size record))
        (sub-addr-delim (opensmtpd-smtp-sub-addr-delim record)))
    (string-append
     (variable->string ciphers #:append "smtp ciphers " #:postpend "\n")
     (variable->string limit-max-mails
                       #:append "smtp limit max-mails " #:postpend "\n")
     (variable->string limit-max-rcpt
                       #:append "smtp limit max-rcpt " #:postpend "\n")
     (variable->string max-message-size
                       #:append "smtp max-message-size " #:postpend "\n")
     (variable->string sub-addr-delim
                       #:append "smtp sub-addr-delim " #:postpend "\n")
     "\n")))

(define (opensmtpd-configuration-queue->string record)
  (let ((compression (opensmtpd-queue-compression record))
        (encryption (opensmtpd-queue-encryption record))
        (ttl-delay (opensmtpd-queue-ttl-delay record)))
    (string-append
     (if compression
         "queue compression\n"
         "")
     (if encryption
         (string-append
          "queue encryption "
          (if (not (boolean? encryption))
              encryption
              "")
          "\n")
         "")
     (if ttl-delay
         (string-append "queue ttl" ttl-delay "\n")
         ""))))

;; build a list of <opensmtpd-action> from
;; opensmtpd-configuration-matches, which is a list of <opensmtpd-match>.
;; Each <opensmtpd-match> has a fieldname 'action', which accepts
;; an <opensmtpd-action>.
(define (get-opensmtpd-actions record)
  (define opensmtpd-actions
    (let loop ((list (opensmtpd-configuration-matches record)))
      (if (null? list)
          '()
          (cons (opensmtpd-match-action (car list))
                (loop (cdr list))))))
  (delete-duplicates (append opensmtpd-actions)))

;; build a list of opensmtpd-pkis from
;; opensmtpd-configuration-interfaces and
;; get-opensmtpd-actions
(define (get-opensmtpd-pkis record)
  ;; TODO/FIXME/maybe/wishlist could get-opensmtpd-actions -> NOT have an
  ;; opensmtpd-relay?
  ;; I think so.  And if it did NOT have a relay configuration, then
  ;; action-pkis would be '() when it needs to be #f.  because if the
  ;; opensmtpd-configuration has NO pkis, then this function will
  ;; return '(), when it should return #f.  If it returns '(), then
  ;; opensmtpd-configuration-fieldname->string will
  ;; print the string "\n" instead of ""
  (define action-pkis
    (let loop1 ((list (get-opensmtpd-actions record)))
      (if (null? list)
          '()
          (if (and (opensmtpd-relay? (car list))
                   (opensmtpd-relay-pki (car list)))
              (cons (opensmtpd-relay-pki (car list))
                    (loop1 (cdr list)))
              (loop1 (cdr list))))))
  ;; FIXME/TODO/maybe/wishlist
  ;; this could be #f aka left blank. aka there are no interface records
  ;; with pkis. aka there are no lines in the configuration like:
  ;; listen on eth0 tls pki smtp.gnucode.me
  ;; in that case the smtpd.conf will have an extra "\n"
  (define listen-on-pkis
    (let loop2 ((list (opensmtpd-configuration-interfaces record)))
      (if (null? list)
          '()
          (if (opensmtpd-interface-pki (car list))
              (cons (opensmtpd-interface-pki (car list))
                    (loop2 (cdr list)))
              (loop2 (cdr list))))))
  (delete-duplicates (append action-pkis listen-on-pkis)))

;; takes in a <opensmtpd-configuration> and returns a list whose
;; elements are <opensmtpd-filter>, <opensmtpd-filter-phase>,
;; and a filter-chain.
;; It returns a list of <opensmtpd-filter> and/or <opensmtpd-filter-phase>
;; here's an example of what this procedure might return:
;; (list (opensmtpd-filter...) (opensmtpd-filter-phase ...)
;;       (openmstpd-filter ...) (opensmtpd-filter-phase ...)
;;       ;; this next list is a filter-chain.
;;       (list (opensmtpd-filter-phase ...) (opensmtpd-filter...)))
;;
;; This procedure handles filter chains a little odd.
(define (get-opensmtpd-filters record)
  (define socket-filters
    (if (and (opensmtpd-configuration-socket record)
             (opensmtpd-socket-filters
              (opensmtpd-configuration-socket record)))
        (opensmtpd-socket-filters (opensmtpd-configuration-socket record))
        '()))
  (define list-of-interfaces
    (if (opensmtpd-configuration-interfaces record)
        (opensmtpd-configuration-interfaces record)
        '()))

  (delete-duplicates
   (append
    (remove boolean?
            (map-in-order
             ;; get the filters found in the <listen-on-record>s
             (lambda (interface-or-socket-record)
               (if (and
                    (opensmtpd-interface-filters interface-or-socket-record)
                    (= 1 (length (opensmtpd-interface-filters
                                  interface-or-socket-record))))
                   ;; this next line returns an <opensmtpd-interface>
                   (car (opensmtpd-interface-filters
                         interface-or-socket-record))
                   ;; this next line returns a filter chain.
                   (opensmtpd-interface-filters interface-or-socket-record)))
             list-of-interfaces))
    socket-filters)))

(define (flatten . lst)
  "Return a list that recursively concatenates all sub-lists of LST."
  (define (flatten1 head out)
    (if (list? head)
        (fold-right flatten1 out head)
        (cons head out)))
  (fold-right flatten1 '() lst))

;; This function takes in a record, or list, or anything, and returns
;; a list of <opensmtpd-table>s assuming the thing you passed into it had
;; any <opensmtpd-table>s.
;;
;; is object record? call func on it's fieldnames
;; is object list? loop through it's fieldnames calling func on it's records
;; is object #f or string? or '()? -> #f
(define (get-opensmtpd-tables value)
  (delete-duplicates
   (remove boolean?
           (flatten ;; turn (list '(1) '(2 '(3))) -> '(1 2 3)
            (cond ((opensmtpd-table? value)
                   value)
                  ((record? value)
                   (let* ((record-type (record-type-descriptor value))
                          (list-of-record-fieldnames
                           (record-type-fields record-type)))
                     (map (lambda (fieldname)
                            (get-opensmtpd-tables
                             ((record-accessor record-type fieldname)
                              value)))
                          list-of-record-fieldnames)))
                  ((and (list? value) (not (null? value)))
                   (map get-opensmtpd-tables value))
                  (else #f))))))

(define (opensmtpd-configuration-fieldname->string
         record fieldname-accessor record->string)
  (if (fieldname-accessor record)
      (begin
        (string-append
         (list-of-records->string (fieldname-accessor record)
                                  record->string) "\n"))
      ""))

(define (list-of-records->string list-of-records record->string)
  (string-append
   (cond ((not (list? list-of-records))
          (record->string list-of-records))
         (else
          (let loop ((list list-of-records))
            (if (null? list)
                ""
                (string-append
                 (record->string (car list))
                 (loop (cdr list)))))))))

(define (opensmtpd-configuration->string record)
  ;; should I use this named let, or should I give this a name, or
  ;; not use it at all...
  ;; eg:
  ;; (write-all-fieldnames
  ;;   (list (cons fieldname fieldname->string)
  ;;         (cons fieldname2 fieldname->string)))
  ;; (let loop ([list
  ;;            (list
  ;;              (cons opensmtpd-configuration-includes
  ;;                    (lambda (string)
  ;;                      (string-append
  ;;                        "include \"" string "\"\n")))
  ;;              (cons opensmtpd-configuration-smtp opensmtpd-smtp->string)
  ;;              (cons opensmtpd-configuration-srs opensmtpd-srs->string))])
  ;;   (if (null? list)
  ;;       ""
  ;;       (string-append
  ;;         (opensmtpd-configuration-fieldname->string record
  ;;          (caar list)
  ;;          (cdar list))
  ;;          (loop (cdr list)))))
  (string-append
   (opensmtpd-configuration-fieldname->string
    record opensmtpd-configuration-bounce
    (lambda (%bounce)
      (if %bounce
          (list-of-strings->string %bounce)
          "")))
   (opensmtpd-configuration-fieldname->string record
                                              opensmtpd-configuration-smtp
                                              opensmtpd-smtp->string)
   (opensmtpd-configuration-fieldname->string
    record
    opensmtpd-configuration-srs
    opensmtpd-configuration-srs->string)
   (opensmtpd-configuration-fieldname->string
    record
    opensmtpd-configuration-queue
    opensmtpd-configuration-queue->string)
   ;; write out the mta-max-deferred
   (opensmtpd-configuration-fieldname->string
    record opensmtpd-configuration-mta-max-deferred
    (lambda (var)
      (string-append "mta max-deferred "
                     (number->string
                      (opensmtpd-configuration-mta-max-deferred record))
                     "\n")))
   ;;write out all the tables
   (opensmtpd-configuration-fieldname->string record get-opensmtpd-tables
                                              opensmtpd-table->string)
   ;; write out all the cas
   (opensmtpd-configuration-fieldname->string record
                                              opensmtpd-configuration-cas
                                              opensmtpd-ca->string)
   ;; write out all the pkis
   (opensmtpd-configuration-fieldname->string record get-opensmtpd-pkis
                                              opensmtpd-pki->string)
   ;; write all of the interface and socket records
   (opensmtpd-configuration-fieldname->string
    record
    opensmtpd-configuration-interfaces
    opensmtpd-interface->string)
   (opensmtpd-configuration-fieldname->string record
                                              opensmtpd-configuration-socket
                                              opensmtpd-socket->string)
   ;; write all the actions
   (opensmtpd-configuration-fieldname->string record get-opensmtpd-actions
                                              opensmtpd-action->string)
   ;; write all of the matches
   (opensmtpd-configuration-fieldname->string record
                                              opensmtpd-configuration-matches
                                              opensmtpd-match->string)))

;; FIXME/TODO should I use format here srfi-28 ?
;; web.scm nginx does a (format #f "string" "another string")
;; this could be a list like
;; (list
;;   (file-append opensmtpd-dkimsign "/libexec/filter")
;;   "-d gnucode.me -s /path/to/selector.cert")
;; Then opensmtpd-configuration->mixed-text-file could be rewritten to be
;; something like
;; (mixed-text-file
;;   (eval `(string-append (opensmtpd-configuration-fieldname->string ...))
;;   (gnu services mail)))
(define (opensmtpd-configuration->mixed-text-file record)
  (apply mixed-text-file "smtpd.conf"
         (flatten (list
                   ;; write out the includes
                   (opensmtpd-configuration-fieldname->string
                    record
                    opensmtpd-configuration-includes
                    opensmtpd-configuration-includes->string)
                   ;; TODO should I change the below line of code into these
                   ;; two lines of code?
                   ;;(opensmtpd-configuration-fieldname->string
                   ;;  record get-opensmtpd-filters-and-filter-phases
                   ;;  opensmtpd-filter-and-filter-phase->string)
                   ;;(opensmtpd-configuration-fieldname->string
                   ;;  record get-opensmtpd-filter-chains
                   ;;  opensmtpd-filter-chain->string)
                   ;; write out all the filters
                   (opensmtpd-filters->list-of-strings-and-gexps
                    (get-opensmtpd-filters record))
                   (opensmtpd-configuration->string record)))))

(define %default-opensmtpd-config-file
  (plain-file "smtpd.conf" "
listen on lo

action inbound mbox
match for local action inbound

action outbound relay
match from local for any action outbound
"))

(define (opensmtpd-shepherd-service config)
  (list (shepherd-service
            (provision '(smtpd))
            (requirement '(loopback))
            (documentation "Run the OpenSMTPD daemon.")
            (start
             (let ((smtpd (file-append
                           (opensmtpd-configuration-package config)
                           "/sbin/smtpd")))
               #~(make-forkexec-constructor
                  (list #$smtpd "-f"
                        (or
                         #$(opensmtpd-configuration-config-file config)
                         #$(opensmtpd-configuration->mixed-text-file config)))
                  #:pid-file "/var/run/smtpd.pid")))
            (stop #~(make-kill-destructor)))))

;; TODO why does the below NOT work?
;(define (opensmtpd-shepherd-service config)
;  (match-lambda
;    (($ <opensmtpd-configuration> package config-file)
;     (list (shepherd-service
;            (provision '(smtpd))
;            (requirement '(loopback))
;            (documentation "Run the OpenSMTPD daemon.")
;            (start (let ((smtpd (file-append package "/sbin/smtpd")))
;                     #~(make-forkexec-constructor
;                        (list #$smtpd "-f" (or #$config-file
;                                               #$(opensmtpd-configuration->mixed-text-file config)))
;                        #:pid-file "/var/run/smtpd.pid")))
;            (stop #~(make-kill-destructor)))))))

(define %opensmtpd-accounts
  (list (user-group
         (name "smtpq")
         (system? #t))
        (user-account
         (name "smtpd")
         (group "nogroup")
         (system? #t)
         (comment "SMTP Daemon")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))
        (user-account
         (name "smtpq")
         (group "smtpq")
         (system? #t)
         (comment "SMTPD Queue")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))))

(define (opensmtpd-activation config)
  (let ((smtpd (file-append (opensmtpd-configuration-package config) "/sbin/smtpd"))
        (config-file (opensmtpd-configuration-config-file config))
        (configuration (opensmtpd-configuration->mixed-text-file config)))
       #~(begin
           (use-modules (guix build utils))
           ;; Create mbox and spool directories.
           (mkdir-p "/var/mail")
           (mkdir-p "/var/spool/smtpd")
           (chmod "/var/spool/smtpd" #o711)
           (mkdir-p "/var/spool/mail")
           (chmod "/var/spool/mail" #o711)
           (display (string-append "checking syntax of "
                                   (or
                                    #$config-file
                                    #$configuration)
                                   "\n"))
           (system* #$smtpd "-nf"
                    (or
                     #$config-file
                     #$configuration)))))

;; TODO why does this not work?
;(define (opensmtpd-activation config)
;  (match-lambda
;    (($ <opensmtpd-configuration> package config-file)
;     (let ((smtpd (file-append package "/sbin/smtpd"))
;           (configuration (opensmtpd-configuration->mixed-text-file config)))
;       #~(begin
;           (use-modules (guix build utils))
           ;; Create mbox and spool directories.
;           (mkdir-p "/var/mail")
;          (mkdir-p "/var/spool/smtpd")
;         (chmod "/var/spool/smtpd" #o711)
;        (mkdir-p "/var/spool/mail")
;           (chmod "/var/spool/mail" #o711)
;           (display (string-append "checking syntax of "
;                                  (or
;                                    #$config-file
;                                    #$configuration)
;                                   "\n")))))))

(define %opensmtpd-pam-services
  (list (unix-pam-service "smtpd")))

(define opensmtpd-set-gids
  (match-lambda
    (($ <opensmtpd-configuration> package config-file set-gids?)
     (if set-gids?
         (list
          (setuid-program
           (program (file-append package "/sbin/smtpctl"))
           (setuid? #false)
           (setgid? #true)
           (group "smtpq"))
          (setuid-program
           (program (file-append package "/sbin/sendmail"))
           (setuid? #false)
           (setgid? #true)
           (group "smtpq"))
          (setuid-program
           (program (file-append package "/sbin/send-mail"))
           (setuid? #false)
           (setgid? #true)
           (group "smtpq"))
          (setuid-program
           (program (file-append package "/sbin/makemap"))
           (setuid? #false)
           (setgid? #true)
           (group "smtpq"))
          (setuid-program
           (program (file-append package "/sbin/mailq"))
           (setuid? #false)
           (setgid? #true)
           (group "smtpq"))
          (setuid-program
           (program (file-append package "/sbin/newaliases"))
           (setuid? #false)
           (setgid? #true)
           (group "smtpq")))
         '()))))

(define opensmtpd-service-type
  (service-type
   (name 'opensmtpd)
   (extensions
    (list (service-extension account-service-type
                             (const %opensmtpd-accounts))
          (service-extension activation-service-type
                             opensmtpd-activation)
          (service-extension pam-root-service-type
                             (const %opensmtpd-pam-services))
          (service-extension profile-service-type
                             (compose list opensmtpd-configuration-package))
          (service-extension shepherd-root-service-type
                             opensmtpd-shepherd-service)
          (service-extension setuid-program-service-type
                             opensmtpd-set-gids)))
   (description "Run the OpenSMTPD, a lightweight @acronym{SMTP, Simple Mail
Transfer Protocol} server.")))