@@ -57,8 +57,143 @@ (define-module (gnu services mail)
mailbox-configuration
namespace-configuration
+ opensmtpd-table-configuration
+ opensmtpd-table-configuration?
+ opensmtpd-table-configuration-name
+ opensmtpd-table-configuration-file-db
+ opensmtpd-table-configuration-data
+
+ opensmtpd-ca-configuration
+ opensmtpd-ca-configuration?
+ opensmtpd-ca-configuration-name
+ opensmtpd-ca-configuration-file
+
+ opensmtpd-pki-configuration
+ opensmtpd-pki-configuration?
+ opensmtpd-pki-configuration-domain
+ opensmtpd-pki-configuration-cert
+ opensmtpd-pki-configuration-key
+ opensmtpd-pki-configuration-dhe
+
+ opensmtpd-action-local-delivery-configuration
+ opensmtpd-action-local-delivery-configuration?
+ opensmtpd-action-local-delivery-configuration-method
+ opensmtpd-action-local-delivery-configuration-alias
+ opensmtpd-action-local-delivery-configuration-ttl
+ opensmtpd-action-local-delivery-configuration-user
+ opensmtpd-action-local-delivery-configuration-userbase
+ opensmtpd-action-local-delivery-configuration-virtual
+ opensmtpd-action-local-delivery-configuration-wrapper
+
+ opensmtpd-maildir-configuration
+ opensmtpd-maildir-configuration?
+ opensmtpd-maildir-configuration-pathname
+ opensmtpd-maildir-configuration-junk
+
+ opensmtpd-mda-configuration
+ opensmtpd-mda-configuration-name
+ opensmtpd-mda-configuration-command
+
+ opensmtpd-action-relay-configuration
+ opensmtpd-action-relay-configuration?
+ opensmtpd-action-relay-configuration-backup
+ opensmtpd-action-relay-configuration-backup-mx
+ opensmtpd-action-relay-configuration-helo
+ opensmtpd-action-relay-configuration-domain
+ opensmtpd-action-relay-configuration-host
+ opensmtpd-action-relay-configuration-pki
+ opensmtpd-action-relay-configuration-srs
+ opensmtpd-action-relay-configuration-tls
+ opensmtpd-action-relay-configuration-auth
+ opensmtpd-action-relay-configuration-mail-from
+ opensmtpd-action-relay-configuration-src
+
+ opensmtpd-option-configuration
+ opensmtpd-option-configuration?
+ opensmtpd-option-configuration-option
+ opensmtpd-option-configuration-not
+ opensmtpd-option-configuration-regex
+ opensmtpd-option-configuration-data
+
+ opensmtpd-filter-phase-configuration
+ opensmtpd-filter-phase-configuration?
+ opensmtpd-filter-phase-configuration-name
+ opensmtpd-filter-phase-configuration-phase-name
+ opensmtpd-filter-phase-configuration-options
+ opensmtpd-filter-phase-configuration-decision
+ opensmtpd-filter-phase-configuration-message
+ opensmtpd-filter-phase-configuration-value
+
+ opensmtpd-filter-configuration
+ opensmtpd-filter-configuration?
+ opensmtpd-filter-configuration-name
+ opensmtpd-filter-configuration-proc
+
+ opensmtpd-listen-on-configuration
+ opensmtpd-listen-on-configuration?
+ opensmtpd-listen-on-configuration-interface
+ opensmtpd-listen-on-configuration-family
+ opensmtpd-listen-on-configuration-auth
+ opensmtpd-listen-on-configuration-auth-optional
+ opensmtpd-listen-on-configuration-filters
+ opensmtpd-listen-on-configuration-hostname
+ opensmtpd-listen-on-configuration-hostnames
+ opensmtpd-listen-on-configuration-mask-src
+ opensmtpd-listen-on-configuration-disable-dsn
+ opensmtpd-listen-on-configuration-pki
+ opensmtpd-listen-on-configuration-port
+ opensmtpd-listen-on-configuration-proxy-v2
+ opensmtpd-listen-on-configuration-received-auth
+ opensmtpd-listen-on-configuration-senders
+ opensmtpd-listen-on-configuration-secure-connection
+ opensmtpd-listen-on-configuration-tag
+
+ opensmtpd-listen-on-socket-configuration
+ opensmtpd-listen-on-socket-configuration?
+ opensmtpd-listen-on-socket-configuration-filters
+ opensmtpd-listen-on-socket-configuration-mask-src
+ opensmtpd-listen-on-socket-configuration-tag
+
+ opensmtpd-match-configuration
+ opensmtpd-match-configuration?
+ opensmtpd-match-configuration-action
+ opensmtpd-match-configuration-options
+
+ opensmtpd-smtp-configuration
+ opensmtpd-smtp-configuration?
+ opensmtpd-smtp-configuration-ciphers
+ opensmtpd-smtp-configuration-limit-max-mails
+ opensmtpd-smtp-configuration-limit-max-rcpt
+ opensmtpd-smtp-configuration-max-message-size
+ opensmtpd-smtp-configuration-sub-addr-delim character
+
+ opensmtpd-srs-configuration
+ opensmtpd-srs-configuration?
+ opensmtpd-srs-configuration-key
+ opensmtpd-srs-configuration-backup-key
+ opensmtpd-srs-configuration-ttl-delay
+
+ opensmtpd-queue-configuration
+ opensmtpd-queue-configuration?
+ opensmtpd-queue-configuration-compression
+ opensmtpd-queue-configuration-encryption
+ opensmtpd-queue-configuration-ttl-delay
+
opensmtpd-configuration
opensmtpd-configuration?
+ opensmtpd-package
+ opensmtpd-config-file
+ opensmtpd-configuration-bounce
+ opensmtpd-configuration-listen-ons
+ opensmtpd-configuration-listen-on-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
%default-opensmtpd-config-file
@@ -1651,13 +1786,1888 @@ (define (generate-dovecot-documentation)
;;; OpenSMTPD.
;;;
+;; some fieldnames have a default value of #f, which is ok. They cannot have a value of #t.
+;; for example opensmtpd-table-configuration-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))
+
+;; 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
+ (cond [(procedure? (car list-of-procedures))
+ (if ((car list-of-procedures) var)
+ #t
+ (is-value-right-type? var (cdr list-of-procedures) record fieldname))]
+ [(and (sanitize-configuration? (car list-of-procedures))
+ (sanitize-configuration-error-if-proc-fails (car list-of-procedures))
+ (if ((sanitize-configuration-proc (car list-of-procedures)) var)
+ #t
+ (begin
+ (apply string-append
+ (sanitize-configuration-error-message (car list-of-procedures)))
+ (throw 'bad! var))))]
+ [else (if ((sanitize-configuration-proc (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))
+
+;; I could test for read-ability of a file, but then I would have to
+;; test the program as root everytime instead of as a normal user...
+(define (file-exists? file)
+(if (string? file)
+ (access? file F_OK)
+ #f))
+
+(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))
+ "boolean, "]
+ [(eq? string? (car procedures))
+ "string, "]
+ [(eq? integer? (car procedures))
+ "integer, "]
+ [(eq? list-of-strings? (car procedures))
+ "list of strings, "]
+ [(eq? assoc-list? (car procedures))
+ "an association list, "]
+ [(eq? opensmtpd-pki-configuration? (car procedures))
+ "an <opensmtpd-pki-configuration> record, "]
+ [(eq? opensmtpd-table-configuration? (car procedures))
+ "an <opensmtpd-table-configuration> record, "]
+ [(eq? list-of-unique-opensmtpd-match-configuration? (car procedures))
+ "a list of unique <opensmtpd-match-configuration> records, "]
+ [(eq? table-whose-data-are-assoc-list? (car procedures))
+ (string-append
+ "an <opensmtpd-table-configuration> record whose fieldname 'values' are an assoc-list \n"
+ "(eg: (opensmtpd-table-configuration (name \"table\") (data '(\"joshua\" . \"$encrypted$password\")))), ")]
+ [(eq? file-exists? (car procedures))
+ "file, "]
+ [else "has an incorrect value, "])
+ (loop (cdr procedures)))))))
+ (add-comma-or (string-append (string-drop-right string 2) ".\n")))
+
+;; TODO can I M-x raise-sexp (string=? string var) in this procedure? and get rid of checking
+;; if the var is a string? The previous string-in-list? had that check.
+;; (string-in-list? '("hello" 5 "cat")) currently works. If I M-x raise-sexp (string=? string var)
+;; then it will no longer work.
+(define (string-in-list? string list)
+ (primitive-eval (cons 'or (map (lambda (var) (and (string? var) (string=? string var))) list))))
+
+(define (my/sanitize var record fieldname list-of-procedures)
+ (if (is-value-right-type? var list-of-procedures record fieldname)
+ var
+ (begin
+ (display (string-append "<" record "> fieldname: '" fieldname "' is of type "
+ (list-of-procedures->string list-of-procedures) "\n"))
+ (throw 'bad! var))))
+
+;; Some example opensmtpd-table-configurations:
+;;
+;; (opensmtpd-table-configuration (name "root accounts") (data '(("joshua" . "root@dismail.de") ("joshua" . "postmaster@dismail.de"))))
+;; (opensmtpd-table-configuration (name "root accounts") (data (list "mysite.me" "your-site.com")))
+;; TODO should <opensmtpd-table-configuration> support have a fieldname 'file'?
+;; Or should I change name to name-or-file ?
+(define-record-type* <opensmtpd-table-configuration>
+ opensmtpd-table-configuration make-opensmtpd-table-configuration
+ opensmtpd-table-configuration?
+ this-record
+ (name opensmtpd-table-configuration-name ;; string
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-table-configuration" "name" (list string?)))))
+ (file-db opensmtpd-table-configuration-file-db
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-table-configuration" "file-db"
+ (list boolean?)))))
+ ;; 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-configuration-data
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-table-configuration" "values"
+ (list file-exists? list-of-strings? assoc-list?)))))
+ ;; is a list of values or key values
+ ;; eg: (list "mysite.me" "your-site.com")
+ ;; eg: (list ("joshua" . "joshua@gnu.org") ("james" . "james@gnu.org"))
+ ;; I am currently making these values be as assocation list of strings only.
+ ;; FIXME should I allow a var like this?
+ ;; (list (cons "gnucode.me" 234.949.392.23))
+ ;; can be of type: (quote list-of-strings) or (quote assoc-list)
+ ;; (opensmtpd-table-configuration-type record) returns the values' type. The user SHOULD NEVER set the type.
+ ;; TODO jpoiret: on irc reccomends that I just use an outside function to determine fieldname 'values', type.
+ ;; it would be "simpler" and possibly easier for the next person working on this code to understand what is happening.
+ (type opensmtpd-table-configuration-type
+ (default #f)
+ (thunked)
+ (sanitize (lambda (var)
+ (cond [(opensmtpd-table-configuration-data this-record)
+ (if (list-of-strings? (opensmtpd-table-configuration-data this-record))
+ (quote list-of-strings)
+ (quote assoc-list))]
+ [(file-exists? (opensmtpd-table-configuration-data this-record))
+ (if (opensmtpd-table-configuration-file-db this-record)
+ (quote db)
+ (quote file))]
+ [else
+ (display "opensmtpd-table-configuration-type is broke\n")
+ (throw 'bad! var)])))))
+
+(define-record-type* <opensmtpd-ca-configuration>
+ opensmtpd-ca-configuration make-opensmtpd-ca-configuration
+ opensmtpd-ca-configuration?
+ (name opensmtpd-ca-configuration-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-ca-configuration" "name" (list string?)))))
+ (file opensmtpd-ca-configuration-file
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-ca-configuration" "file" (list file-exists?))))))
+
+(define-record-type* <opensmtpd-pki-configuration>
+ opensmtpd-pki-configuration make-opensmtpd-pki-configuration
+ opensmtpd-pki-configuration?
+ (domain opensmtpd-pki-configuration-domain
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-pki-configuration" "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, de‐
+ ;; rived from the default hostname or set using either
+ ;; /gnu/store/2d13sdz76ldq8zgwv4wif0zx7hkr3mh2-opensmtpd-6.8.0p2/etc/mailname or us‐
+ ;; ing 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, includ‐
+ ;; ing a Certificate Authority certificate, to certfile. The creation of certifi‐
+ ;; cates is documented in starttls(8).
+ (cert opensmtpd-pki-configuration-cert
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-pki-configuration" "cert" (list file-exists?)))))
+ (key opensmtpd-pki-configuration-key
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-pki-configuration" "key" (list file-exists?)))))
+ ; todo sanitize this. valid parameters are "none", "legacy", or "auto".
+ (dhe opensmtpd-pki-configuration-dhe
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-dhe" "dhe" (list false? string?))))))
+
+(define-record-type* <opensmtpd-lmtp-configuration>
+ opensmtpd-lmtp-configuration make-opensmtpd-lmtp-configuration
+ opensmtpd-lmtp-configuration?
+ (destination opensmtpd-lmtp-configuration-destination
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-lmtp-configuration" "destination"
+ (list string?)))))
+ (rcpt-to opensmtpd-lmtp-configuration-rcpt-to
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-lmtp-configuration" "rcpt-to"
+ (list false? string?))))))
+
+(define-record-type* <opensmtpd-mda-configuration>
+ opensmtpd-mda-configuration make-opensmtpd-mda-configuration
+ opensmtpd-mda-configuration?
+ (name opensmtpd-mda-configuration-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-mda-configuration" "name"
+ (list string?)))))
+ ;; TODO should I allow this command to be a gexp?
+ (command opensmtpd-mda-configuration-command
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-mda-configuration" "command"
+ (list string?))))))
+
+(define-record-type* <opensmtpd-maildir-configuration>
+ opensmtpd-maildir-configuration make-opensmtpd-maildir-configuration
+ opensmtpd-maildir-configuration?
+ (pathname opensmtpd-maildir-configuration-pathname
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-maildir-configuration" "pathname"
+ (list false? string?)))))
+ (junk opensmtpd-maildir-configuration-junk
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-maildir-configuration" "junk"
+ (list boolean?))))))
+
+(define-record-type* <opensmtpd-action-local-delivery-configuration>
+ opensmtpd-action-local-delivery-configuration make-opensmtpd-action-local-delivery-configuration
+ opensmtpd-action-local-delivery-configuration?
+ (name opensmtpd-action-local-delivery-configuration-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-local-delivery-configuration" "name"
+ (list string?)))))
+ (method opensmtpd-action-local-delivery-configuration-method
+ (default "mbox")
+ (sanitize (lambda (var)
+ (cond
+ [(or (opensmtpd-lmtp-configuration? var)
+ (opensmtpd-maildir-configuration? var)
+ (opensmtpd-mda-configuration? var)
+ (string=? var "mbox")
+ (string=? var "expand-only")
+ (string=? var "forward-only"))
+ var]
+ [else
+ (begin
+ (display (string-append "<opensmtpd-action-local-delivery-configuration> fieldname 'method' must be of type \n"
+ "\"mbox\", \"expand-only\", \"forward-only\" \n"
+ "<opensmtpd-lmtp-configuration>, <opensmtpd-maildir-configuration>, \n"
+ "or <opensmtpd-mda-configuration>.\n"))
+ (throw 'bad! var))]))))
+ (alias opensmtpd-action-local-delivery-configuration-alias
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-local-delivery-configuration" "alias"
+ (list false? opensmtpd-table-configuration?)))))
+ (ttl opensmtpd-action-local-delivery-configuration-ttl
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-local-delivery-configuration" "ttl"
+ (list false? string?)))))
+ (user opensmtpd-action-local-delivery-configuration-user
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-local-delivery-configuration" "user"
+ (list false? string?)))))
+ (userbase opensmtpd-action-local-delivery-configuration-userbase
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-local-delivery-configuration" "userbase"
+ (list false? opensmtpd-table-configuration?)))))
+ (virtual opensmtpd-action-local-delivery-configuration-virtual
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-local-delivery-configuration" "virtual"
+ (list false? opensmtpd-table-configuration?)))))
+ (wrapper opensmtpd-action-local-delivery-configuration-wrapper
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-local-delivery-configuration" "wrapper"
+ (list false? string?))))))
+
+;; FIXME/TODO this is a valid opensmtpd-relay record
+;; (opensmtpd-action-relay-configuration
+;; (pki (opensmtpd-pki-configuration
+;; (domain "gnucode.me")
+;; (cert "opensmtpd.scm")
+;; (key "opensmtpd.scm"))))
+;; BUT how does it relay the email? What host does it use?
+;; I think opensmtpd-relay-configuration needs "method" field.
+;; the method field might need to be another record...BUT basically the relay has to have a 'backup', 'backup-mx',
+;; or 'domain', or 'host' defined.
+(define-record-type* <opensmtpd-action-relay-configuration>
+ opensmtpd-action-relay-configuration make-opensmtpd-action-relay-configuration
+ opensmtpd-action-relay-configuration?
+ (name opensmtpd-action-relay-configuration-name
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "name"
+ (list string?))))
+ (default #f))
+ (backup opensmtpd-action-relay-configuration-backup ;; boolean
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "backup"
+ (list boolean?)))))
+ (backup-mx opensmtpd-action-relay-configuration-backup-mx ;; string mx name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "backup-mx"
+ (list false? string?)))))
+ (helo opensmtpd-action-relay-configuration-helo
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "helo"
+ (list false? string? opensmtpd-table-configuration?))))
+ (default #f))
+ (helo-src opensmtpd-action-relay-configuration-helo-src
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "helo-src"
+ (list false? string? opensmtpd-table-configuration?))))
+ (default #f))
+ (domain opensmtpd-action-relay-configuration-domain
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "domain"
+ (list false? opensmtpd-table-configuration?))))
+ (default #f))
+ (host opensmtpd-action-relay-configuration-host
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "host"
+ (list false? string?))))
+ (default #f))
+ (pki opensmtpd-action-relay-configuration-pki
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "pki"
+ (list false? opensmtpd-pki-configuration?)))))
+ (srs opensmtpd-action-relay-configuration-srs
+ (default #f)
+ (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "srs"
+ (list boolean?))))
+ (tls opensmtpd-action-relay-configuration-tls
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "tls"
+ (list false? string?)))))
+ (auth opensmtpd-action-relay-configuration-auth
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "auth"
+ (list false? opensmtpd-table-configuration?))))
+ (default #f))
+ (mail-from opensmtpd-action-relay-configuration-mail-from
+ (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-action-relay-configuration-src
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-action-relay-configuration" "src"
+ (list false? string? opensmtpd-table-configuration?))))
+ (default #f)))
+
+;; this record is used by <opensmtpd-filter-phase-configuration> &
+;; <opensmtpd-match-configuration>
+(define-record-type* <opensmtpd-option-configuration>
+ opensmtpd-option-configuration make-opensmtpd-option-configuration
+ opensmtpd-option-configuration?
+ (option opensmtpd-option-configuration-option
+ (default #f)
+ (sanitize (lambda (var)
+ (if (and (string? var)
+ (or (string-in-list? var (list "fcrdns" "rdns"
+ "src" "helo"
+ "auth" "mail-from"
+ "rcpt-to"
+ "for"
+ "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"
+ ))))
+ var
+ (begin
+ (display (string-append "<opensmtpd-option-configuration> fieldname: 'option' is of type \n"
+ "string. The string can be either 'fcrdns', \n"
+ " 'rdns', 'src', 'helo', 'auth', 'mail-from', or 'rcpt-to', \n"
+ "'for', 'for any', 'for local', 'for domain', 'for rcpt-to', \n"
+ "'from any', 'from auth', 'from local', 'from mail-from', 'from rdns', 'from socket', \n"
+ "'from src', 'auth helo', 'mail-from', 'rcpt-to', 'tag', or 'tls' \n"
+ ))
+ (throw 'bad! var))))))
+ (not opensmtpd-option-configuration-not
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-option-configuration" "not"
+ (list boolean?)))))
+ (regex opensmtpd-option-configuration-regex
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-option-configuration" "regex"
+ (list boolean?)))))
+ (data opensmtpd-option-configuration-data
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-option-configuration" "data"
+ (list false? string? opensmtpd-table-configuration?))))))
+
+(define-record-type* <opensmtpd-filter-phase-configuration>
+ opensmtpd-filter-phase-configuration make-opensmtpd-filter-phase-configuration
+ opensmtpd-filter-phase-configuration?
+ (name opensmtpd-filter-phase-configuration-name ;; string chain-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter-phase-configuration" "name"
+ (list string?)))))
+ (phase opensmtpd-filter-phase-configuration-phase ;; string
+ (default #f)
+ (sanitize (lambda (var)
+ ;;(my/sanitize var "opensmtpd-filter-phase-configuration" "phase"
+ ;; (list (sanitize-configuration
+ ;; (proc (lambda (value)
+ ;; (and (string? var)
+ ;; (string-in-list? var (list "connect"
+ ;; "helo"
+ ;; "mail-from"
+ ;; "rcpt-to"
+ ;; "data"
+ ;; "commit")))))
+ ;; (error-message (list
+ ;; "<opensmtpd-filter-phase-configuration> fieldname: 'phase' is of type \n"
+ ;; "string. The string can be either 'connect',"
+ ;; " 'helo', 'mail-from', 'rcpt-to', 'data', or 'commit.'\n ")))))
+ (if (and (string? var)
+ (string-in-list? var (list "connect"
+ "helo"
+ "mail-from"
+ "rcpt-to"
+ "data"
+ "commit")))
+ var
+ (begin
+ (display (string-append "<opensmtpd-filter-phase-configuration> fieldname: 'phase' is of type \n"
+ "string. The string can be either 'connect',"
+ " 'helo', 'mail-from', 'rcpt-to', 'data', or 'commit.'\n "
+ ))
+ (throw 'bad! var)))
+ )))
+
+ (options opensmtpd-filter-phase-configuration-options
+ (default #f)
+ (sanitize (lambda (var)
+ ;; returns #t if list is a unique list of <opensmtpd-option-configuration>
+ (define (list-of-opensmtpd-option-configuration? list)
+ (and (list-of-type? list opensmtpd-option-configuration?)
+ (not (contains-duplicate? list))))
+
+ (define (list-has-duplicates-or-non-opensmtpd-option-configuration list)
+ (not (list-of-opensmtpd-option-configuration? list)))
+
+ ;; input <opensmtpd-option-configuration>
+ ;; return #t if <opensmtpd-option-configuration> fieldname 'option'
+ ;; that needs a corresponding table has one. Otherwise #f
+ (define (opensmtpd-option-configuration-has-table? record)
+ (define decision (opensmtpd-option-configuration-option record))
+ (and (string? decision)
+ ;; if option needs a table, check for a table
+ (if (string-in-list? decision (list "src"
+ "helo"
+ "mail-from"
+ "rcpt-to"))
+ (opensmtpd-table-configuration? (opensmtpd-option-configuration-data record))
+ #t)))
+
+ (define (list-of-opensmtpd-option-configuration-has-table? list)
+ (list-of-type? list opensmtpd-option-configuration-has-table?))
+
+ (define (some-opensmtpd-option-configuration-in-list-lack-table? list)
+ (not (list-of-opensmtpd-option-configuration-has-table? list)))
+
+ ;;each element in list is of type <opensmtpd-option-configuration>
+ (cond [(list-has-duplicates-or-non-opensmtpd-option-configuration var)
+ (begin
+ (display (string-append "<opensmtpd-filter-phase-configuration> fieldname: 'options' is a list of unique \n"
+ "<opensmtpd-option-configuration> records.\n"))
+ (throw 'bad! var))]
+ ;; if fieldname 'option' is of string 'src', 'helo', 'mail-from', 'rcpt-to', then there should be a table
+ [(some-opensmtpd-option-configuration-in-list-lack-table? var)
+ (begin
+ (display (string-append "<opensmtpd-option-configuration>'s fieldname 'option' values of \n"
+ "'src', 'helo', 'mail-from', or 'rcpt-to' need a corresponding 'table' \n"
+ " of type <opensmtpd-table-configuration>. eg: \n"
+ "(opensmtpd-option-configuration \n"
+ " (option \"src\")\n"
+ " (table (opensmtpd-table-configuration \n"
+ " (name \"src-table\")\n"
+ " (data (list \"hello\" \"cat\")))))\n"))
+ ;; TODO it would be nice if the var this error message throws in the bad
+ ;; <opensmtpd-option-configuration>, instead of the list of records.
+ (throw 'bad! var))]
+ [else var]))))
+ (decision opensmtpd-filter-phase-configuration-decision
+ (default #f)
+ (sanitize (lambda (var)
+ (if (and (string? var)
+ (string-in-list? var (list "bypass" "disconnect"
+ "reject" "rewrite" "junk")))
+ var
+ (begin
+ (display (string-append "<opensmtpd-filter-decision> fieldname: 'decision' is of type \n"
+ "string. The string can be either 'bypass',"
+ " 'disconnect', 'reject', 'rewrite', or 'junk'.\n"))
+ (throw 'bad! var))))))
+ (message opensmtpd-filter-phase-configuration-message
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter-phase-configuration" "message"
+ (list false? string?)))))
+ (value opensmtpd-filter-phase-configuration-value
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter-phase-configuration" "value"
+ (list false? number?))))))
+
+(define-record-type* <opensmtpd-filter-configuration>
+ opensmtpd-filter-configuration make-opensmtpd-filter-configuration
+ opensmtpd-filter-configuration?
+ (name opensmtpd-filter-configuration-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?)))))
+ (proc opensmtpd-filter-configuration-proc ; a string like "rspamd" or the command to start it like "/path/to/rspamd --option=arg --2nd-option=arg2"
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter" "proc"
+ (list string?))))))
+
+;; There is another type of filter that opensmtpd supports, which is a filter chain.
+;; A filter chain is a list of <opensmtpd-filter-phase-configuration> and <opensmtpd-filter-configuration>.
+;; 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? That's too simple.
+;; returns #t if list is a unique list of <opensmtpd-filter-configuration> or <opensmtpd-filter-phase-configuration>
+;; returns # otherwise
+(define (opensmtpd-filter-chain? %filters)
+ (and (list-of-unique-filter-or-filter-phase? %filters)
+ (< 1 (length %filters))))
+
+(define-record-type* <opensmtpd-listen-on-configuration>
+ opensmtpd-listen-on-configuration make-opensmtpd-listen-on-configuration
+ opensmtpd-listen-on-configuration?
+ ;; interface may be an IP address, interface group, or domain name
+ (interface opensmtpd-listen-on-configuration-interface
+ (default "lo"))
+ (family opensmtpd-listen-on-configuration-family
+ (default #f)
+ (sanitize (lambda (var)
+ (cond
+ [(eq? #f var) ;; var == #f
+ var]
+ [(and (string? var)
+ (string-in-list? var (list "inet4" "inet6")))
+ var]
+ [else
+ (begin
+ (display "<opensmtpd-listen-on-configuration> fieldname 'family' must be string \"inet4\" or \"inet6\".\n")
+ (throw 'bad! var))]))))
+ (auth opensmtpd-listen-on-configuration-auth
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "auth"
+ (list boolean? table-whose-data-are-assoc-list?)))))
+ (auth-optional opensmtpd-listen-on-configuration-auth-optional
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "auth-optional"
+ (list boolean?
+ table-whose-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-listen-on-configuration-filters
+ (default #f)
+ (sanitize (lambda (var)
+ (sanitize-filters var))))
+ (hostname opensmtpd-listen-on-configuration-hostname
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "hostname"
+ (list false? string?)))))
+ (hostnames opensmtpd-listen-on-configuration-hostnames
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "hostnames"
+ (list false? table-whose-data-are-assoc-list?)))))
+ (mask-src opensmtpd-listen-on-configuration-mask-src
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "mask-src"
+ (list boolean?)))))
+ (disable-dsn opensmtpd-listen-on-configuration-disable-dsn
+ (default #f))
+ (pki opensmtpd-listen-on-configuration-pki
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "pki"
+ (list false? opensmtpd-pki-configuration?)))))
+ (port opensmtpd-listen-on-configuration-port
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "port"
+ (list false? integer?)))))
+ (proxy-v2 opensmtpd-listen-on-configuration-proxy-k2
+ (default #f))
+ (received-auth opensmtpd-listen-on-configuration-received-auth
+ (default #f))
+ ;; TODO add in a senders option!
+ ;; string or <opensmtpd-senders> record
+ ;; (senders opensmtpd-listen-on-configuration-senders
+ ;; (sanitize (lambda (var)
+ ;; (my/sanitize var "opensmtpd-listen-on-configuration" "port" (list false? integer?))))
+ ;; (default #f))
+ (secure-connection opensmtpd-listen-on-configuration-secure-connection
+ (default #f)
+ (sanitize (lambda (var)
+ (cond [(boolean? var)
+ var]
+ [(and (string? var)
+ (string-in-list? var
+ (list "smtps" "tls"
+ "tls-require"
+ "tls-require-verify")))
+ var]
+ [else
+ (begin
+ (display (string-append "<opensmtd-listen-on> fieldname 'secure-connection' can be \n"
+ "one of the following strings: \n'smtps', 'tls', 'tls-require', \n"
+ "or 'tls-require-verify'.\n"))
+ (throw 'bad! var))]))))
+ (tag opensmtpd-listen-on-configuration-tag
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "tag"
+ (list false? string?))))
+ (default #f)))
+
+(define-record-type* <opensmtpd-listen-on-socket-configuration-configuration>
+ opensmtpd-listen-on-socket-configuration-configuration make-opensmtpd-listen-on-socket-configuration-configuration
+ opensmtpd-listen-on-socket-configuration-configuration?
+ ;; false or <opensmtpd-filter-configuration> or list of <opensmtpd-filter-configuration>
+ (filters opensmtpd-listen-on-socket-configuration-configuration-filters
+ (sanitize (lambda (var)
+ (sanitize-filters var)))
+ (default #f))
+ (mask-src opensmtpd-listen-on-socket-configuration-configuration-mask-src
+ (default #f))
+ (tag opensmtpd-listen-on-socket-configuration-configuration-tag
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-listen-on-configuration" "tag"
+ (list false? string?))))
+ (default #f)))
+
+
+(define-record-type* <opensmtpd-match-configuration>
+ opensmtpd-match-configuration make-opensmtpd-match-configuration
+ opensmtpd-match-configuration?
+ ;;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-configuration-action
+ (default #f)
+ (sanitize (lambda (var)
+ (if (or (opensmtpd-action-relay-configuration? var)
+ (opensmtpd-action-local-delivery-configuration? var)
+ (eq? (quote reject) var))
+ var
+ (begin
+ (display
+ (string-append "<opensmtpd-match-configuration> fieldname 'action' is of type <opensmtpd-action-relay-configuration>, \n"
+ "<opensmtpd-action-local-delivery-configuration>, or (quote reject).\n"
+ "If its var is (quote reject), then the match rejects the incoming message\n"
+ "during the SMTP dialogue.\n"))
+ (throw 'bad! var))))))
+ (options opensmtpd-match-configuration-options
+ (default #f)
+ (sanitize (lambda (var)
+ (cond ((not var)
+ #f)
+ ((not (list-of-unique-opensmtpd-option-configuration? var))
+ (throw-error var '("<opensmtpd-match-configuration> fieldname 'options' is a list of unique \n"
+ "<opensmtpd-option-configuration> records. \n")))
+ (else (sanitize-list-of-options-for-match-configuration var)))))))
+
+(define-record-type* <opensmtpd-smtp-configuration>
+ opensmtpd-smtp-configuration make-opensmtpd-smtp-configuration
+ opensmtpd-smtp-configuration?
+ (ciphers opensmtpd-smtp-configuration-ciphers
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp-configuration" "ciphers"
+ (list false? string?)))))
+ (limit-max-mails opensmtpd-smtp-configuration-limit-max-mails
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp-configuration" "limit-max-mails"
+ (list false? integer?)))))
+ (limit-max-rcpt opensmtpd-smtp-configuration-limit-max-rcpt
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp-configuration" "limit-max-rcpt"
+ (list false? integer?)))))
+ (max-message-size opensmtpd-smtp-configuration-max-message-size
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp-configuration" "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-configuration-sub-addr-delim
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp-configuration" "sub-addr-delim"
+ (list false? integer? string?))))))
+
+(define-record-type* <opensmtpd-srs-configuration>
+ opensmtpd-srs-configuration make-opensmtpd-srs-configuration
+ opensmtpd-srs-configuration?
+ ;; TODO should this be a file?
+ (key opensmtpd-srs-configuration-key
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-srs-configuration" "key"
+ (list false? boolean? string?)))))
+ ;; TODO should this also be a file?
+ (backup-key opensmtpd-srs-configuration-backup-key
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-srs-configuration" "backup-key"
+ (list false? integer?)))))
+ (ttl-delay opensmtpd-srs-configuration-ttl-delay
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-srs-configuration" "ttl-delay"
+ (list false? string?))))))
+
+(define-record-type* <opensmtpd-queue-configuration>
+ opensmtpd-queue-configuration make-opensmtpd-queue-configuration
+ opensmtpd-queue-configuration?
+ (compression opensmtpd-queue-configuration-compression
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-queue-configuration" "compression"
+ (list boolean?)))))
+ (encryption opensmtpd-queue-configuration-encryption
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-queue-configuration" "encryption"
+ (list boolean? file-exists? string?)))))
+ (ttl-delay opensmtpd-queue-configuration-ttl-delay
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-queue-configuration" "ttl-delay"
+ (list false? string?))))))
+
(define-record-type* <opensmtpd-configuration>
opensmtpd-configuration make-opensmtpd-configuration
opensmtpd-configuration?
- (package opensmtpd-configuration-package
- (default opensmtpd))
+ (package opensmtpd-configuration-package
+ (default opensmtpd))
(config-file opensmtpd-configuration-config-file
- (default %default-opensmtpd-config-file)))
+ (default #f))
+ ;; FIXME/TODO should I include a admd authservid entry?
+
+ ;; TODO sanitize this properly with perhaps a <sanitize-configuration>.
+ (bounce opensmtpd-configuration-bounce
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "bounce"
+ (list false? list?)))))
+ (cas opensmtpd-configuration-cas
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "cas"
+ (list false? list-of-opensmtpd-ca-configuration?)))))
+ ;; list of many records of type opensmtpd-listen-on-configuration
+ (listen-ons opensmtpd-configuration-listen-ons
+ (default (list (opensmtpd-listen-on-configuration)))
+ (sanitize (lambda (var)
+ (if (list-of-opensmtpd-listen-on-configuration? var)
+ var
+ (begin
+ (display "<opensmtpd-configuration> fieldname 'listen-ons' expects a list of records ")
+ (display "of one or more unique <opensmtpd-listen-on-configuration> records.\n")
+ (throw 'bad! var))))))
+ ;; accepts type <opensmtpd-listen-on-socket-configuration-configuration>
+ (listen-on-socket opensmtpd-configuration-listen-on-socket
+ (default (opensmtpd-listen-on-socket-configuration-configuration)))
+ (includes opensmtpd-configuration-includes ;; list of strings of absolute path names
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "includes"
+ (list false? list-of-strings?)))))
+ (matches opensmtpd-configuration-matches
+ (default (list (opensmtpd-match-configuration
+ (action (opensmtpd-action-local-delivery-configuration
+ (name "local")
+ (method "mbox")))
+ (options (list
+ (opensmtpd-option-configuration
+ (option "for local")))))
+ (opensmtpd-match-configuration
+ (action (opensmtpd-action-relay-configuration
+ (name "outbound")))
+ (options (list
+ (opensmtpd-option-configuration
+ (option "from local"))
+ (opensmtpd-option-configuration
+ (option "for any")))))))
+ ;; TODO perhaps I should sanitize this function like I sanitized the 'filters'.
+ ;; I definitely should sanitize this function a bit more. For example, you could have two different
+ ;; actions, one for local delivery and one for remote, with the same name. I should make sure that
+ ;; I have no two different actions with the same name.
+ (sanitize (lambda (var)
+ ;; Should we do more sanitizing here? eg: "from socket" should NOT have a table or value
+ var
+ (my/sanitize var "opensmtpd-configuration" "matches"
+ (list list-of-unique-opensmtpd-match-configuration?)))))
+ ;; list of many records of type mda-wrapper
+ ;; TODO/FIXME support using gexps here
+ ;; eg (list "name" gexp)
+ (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?)))))
+
+ ;; TODO should I add a fieldname proc _proc-name_ _command_ as found in the man 5 smtpd.conf ?
+
+ (queue opensmtpd-configuration-queue
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "queue"
+ (list false? opensmtpd-queue-configuration?)))))
+ (smtp opensmtpd-configuration-smtp
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "smtp"
+ (list false? opensmtpd-smtp-configuration?)))))
+ (srs opensmtpd-configuration-srs
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "srs"
+ (list false? opensmtpd-srs-configuration?))))))
+
+;; This is a non-exported record for passing around sanitize procedures.
+;; As of 5/2/2022 I am not using it. I should probably just delete it.
+(define-record-type* <sanitize-configuration>
+ sanitize-configuration make-sanitize-configuration
+ sanitize-configuration?
+ (proc sanitize-configuration-proc
+ (default #f)
+ ;;(sanitize (lambda (var) (procedure? var)))
+ )
+ (args sanitize-configuration-args
+ (default #f)
+ ;;(sanitize (lambda (var) (lambda (var) (list? var))))
+ )
+ (error-message sanitize-configuration-error-message
+ (default #f)
+ ;;(sanitize (lambda (var) (list? var)))
+ )
+ (error-if-proc-fails sanitize-configuration-error-if-proc-fails
+ (default #f)))
+
+;; this help procedure is used 3 or 4 times by sanitize-list-of-options-for-match-configuration
+(define (throw-error-duplicate-option option error-arg)
+ (throw-error error-arg
+ (list "<opensmtpd-match-configuration>'s fieldname 'options' has two\n"
+ (string-append "<opensmtpd-option-configuration> records with fieldname 'option' with value '" option "'. \n")
+ (string-append "You can only have one option with value '" option "' in the options list.\n"))))
+
+;; this procedure sanitizes the fieldname opensmtpd-match-configuration-options
+(define* (sanitize-list-of-options-for-match-configuration %options)
+ (let loop ([%traversing-options %options]
+ [%sanitized-options '()])
+ (if (null? %traversing-options)
+ (remove false?
+ (list
+ (assoc-ref %sanitized-options "for")
+ (assoc-ref %sanitized-options "from")
+ (assoc-ref %sanitized-options "auth")
+ (assoc-ref %sanitized-options "helo")
+ (assoc-ref %sanitized-options "mail-from")
+ (assoc-ref %sanitized-options "rcpt-to")
+ (assoc-ref %sanitized-options "tag")
+ (assoc-ref %sanitized-options "tls")))
+ (let* ((option-record (car %traversing-options))
+ (option-string (opensmtpd-option-configuration-option option-record)))
+ (cond [(string=? "auth" option-string)
+ (if (assoc-ref %sanitized-options "auth")
+ (throw-error-duplicate-option "auth" %traversing-options)
+ (loop (cdr %traversing-options) (alist-cons "auth" option-record %sanitized-options)))]
+ [(string=? "helo" option-string)
+ (cond [(assoc-ref %sanitized-options "helo")
+ (throw-error-duplicate-option "helo" %traversing-options)]
+ [(not (opensmtpd-option-configuration-data option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option-configuration> with fieldname 'option' with value 'helo' \n"
+ "must have a 'data' of type string or <opensmtpd-table-configuration>.\n"))]
+ [else (loop (cdr %traversing-options) (alist-cons "helo" option-record %sanitized-options))])]
+ [(string=? "mail-from" option-string)
+ (cond ((assoc-ref %sanitized-options "mail-from")
+ (throw-error-duplicate-option "mail-from" %traversing-options))
+ ((not (opensmtpd-option-configuration-data option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option-configuration> with fieldname 'option' with value 'mail-from' \n"
+ "must have a 'data' of type string or <opensmtpd-table-configuration>.\n")))
+ (else (loop (cdr %traversing-options) (alist-cons "mail-from" option-record %sanitized-options))))]
+ [(string=? "rcpt-to" option-string)
+ (cond [(assoc-ref %sanitized-options "rcpt-to")
+ (throw-error-duplicate-option "rcpt-to" %traversing-options)]
+ [(not (opensmtpd-option-configuration-data option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option-configuration> with fieldname 'option' with value 'rcpt-to' \n"
+ "must have a 'data' of type string or <opensmtpd-table-configuration>.\n"))]
+ [else (loop (cdr %traversing-options) (alist-cons "rcpt-to" option-record %sanitized-options))])]
+ [(string=? "tag" option-string)
+ (cond ((assoc-ref %sanitized-options "tag")
+ (throw-error-duplicate-option "tag" %traversing-options))
+ ((not (string? (opensmtpd-option-configuration-data option-record)))
+ (throw-error option-record
+ (list "<opensmtpd-option-configuration> with fieldname 'option' with value 'tag' \n"
+ "must have a 'data' of type string.\n")))
+ (else (loop (cdr %traversing-options) (alist-cons "tag" option-record %sanitized-options))))]
+ [(string=? "tls" option-string)
+ (cond [(assoc-ref %sanitized-options "tls")
+ (throw-error-duplicate-option "tls" %traversing-options)]
+ [(or (opensmtpd-option-configuration-data option-record)
+ (opensmtpd-option-configuration-regex option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option-configuration> with fieldname 'option' with value 'tls' \n"
+ "cannot have a string or table 'data'.\n"))]
+ [else (loop (cdr %traversing-options) (alist-cons "tls" option-record %sanitized-options))])]
+ [(string=? "for" (substring option-string 0 3))
+ (cond ((assoc-ref %sanitized-options "for")
+ (throw-error %options
+ `("<opensmtpd-match-configuration>'s fieldname 'options' can only have one 'for' option. \n"
+ "But '" ,option-string "' and '"
+ ,(opensmtpd-option-configuration-option (assoc-ref %sanitized-options "for")) "' are present.\n")))
+ ((and (string-in-list? option-string (list "for any" "for local")) ; for any cannot have a data field.
+ (or (opensmtpd-option-configuration-data option-record)
+ (opensmtpd-option-configuration-regex option-record)))
+ (throw-error option-record
+ (list "When <openmstpd-option-configuration>'s fieldname 'options' value is 'for any' \n"
+ "or 'for local', then its 'data' and 'regex' field must be #f. \n")))
+ ((and (string-in-list? option-string (list "for domain" "for rcpt-to")) ; for domain must have a data field.
+ (not (opensmtpd-option-configuration-data option-record)))
+ (throw-error option-record
+ (list "When <openmstpd-option-configuration>'s fieldname 'options' value is 'for domain' \n"
+ "or 'for rcpt-to', then its 'data' field must be a string or an \n"
+ "<opensmtpd-table-configuration> record.\n")))
+ (else (loop (cdr %traversing-options) (alist-cons "for" option-record %sanitized-options))))]
+ [(string=? "from" (substring option-string 0 4))
+ (cond ((assoc-ref %sanitized-options "from")
+ (throw-error %options
+ `("<opensmtpd-match-configuration>'s fieldname 'options' can only have one 'from' option. \n"
+ "But '" ,option-string "' and '"
+ ,(opensmtpd-option-configuration-option (assoc-ref %sanitized-options "from")) "' are present.\n")))
+ ((and (string-in-list? option-string (list "from any" "from local" "from socket")) ; for any cannot have a data field.
+ (or (opensmtpd-option-configuration-data option-record)
+ (opensmtpd-option-configuration-regex option-record)))
+ (throw-error option-record
+ (list "When <openmstpd-option-configuration>'s fieldname 'options' value is 'from any', \n"
+ " 'from local', or 'from socket', then its 'data' and 'regex' field must be #f. \n")))
+ ((and (string-in-list? option-string (list "from mail-from" "from src")) ; for domain must have a data field.
+ (not (opensmtpd-option-configuration-data option-record)))
+ (throw-error option-record
+ (list "When <openmstpd-option-configuration>'s fieldname 'options' value is 'from mail-from' \n"
+ "or 'from src', then its 'data' field must be a string or an \n"
+ "<opensmtpd-table-configuration> record.\n")))
+ (else (loop (cdr %traversing-options) (alist-cons "from" option-record %sanitized-options))))])))))
+
+;; some procedures for <opensmtpd-listen-on-configuration> and
+;; <opensmtpd-listen-on-socket-configuration-configuration>.
+(define (sanitize-filters %list)
+ ;; the order of the first two tests in this cond is important.
+ ;; (false?) has to be 1st and (list-has-duplicates-or-non-filters?) has to be second.
+ ;; You may optionally re-order the other alternates in the cond.
+ (cond [(false? %list)
+ #f]
+ [(list-has-duplicates-or-non-filters? %list)
+ (begin
+ (display (string-append "<opensmtpd-listen-on-configuration> fieldname: 'filters' is a list, in which each unique element \n"
+ "is of type <opensmtpd-filter-configuration> or <opensmtpd-filter-phase-configuration>.\n"))
+ (throw 'bad! %list))]
+ [else
+ (let loop ([%traversing-list %list]
+ [%original-list %list])
+ (if (null? %traversing-list)
+ %original-list
+ (cond
+ [(opensmtpd-filter-configuration? (car %traversing-list))
+ (loop (cdr %traversing-list) %original-list)]
+ [(filter-phase-has-message-and-value? (car %traversing-list))
+ (begin
+ (display (string-append "<opensmtpd-filter-phase-configuration> cannot have defined fieldnames 'value' \n"
+ "and 'message'.\n"))
+ (throw 'bad! (car %traversing-list)))]
+ [(filter-phase-decision-lacks-proper-message? (car %traversing-list))
+ (begin
+ (display (string-append "<opensmtpd-filter-phase-configuration> fieldname: 'decision' options \n"
+ "\"disconnect\" and \"reject\" require fieldname 'message' to have a string.\n"
+ "The 'message' string must be RFC commpliant, which means that the string \n"
+ "must begin with a 4xx or 5xx status code.\n"))
+ (throw 'bad! (car %traversing-list)))]
+ [(filter-phase-lacks-proper-value? (car %traversing-list))
+ (begin
+ (display (string-append "<opensmtpd-filter-phase-configuration> fieldname: 'decision' option \n"
+ "\"rewrite\" requires fieldname 'value' to have a number.\n"))
+ (throw 'bad! (car %traversing-list)))]
+ [(filter-phase-has-incorrect-junk-or-bypass? (car %traversing-list))
+ (begin
+ (display (string-append "<opensmtpd-filter-phase-configuration> fieldname 'decision' option \n"
+ "\"junk\" or 'bypass' cannot have a defined fieldnames 'message' or 'value'.\n"))
+ (throw 'bad! (car %traversing-list)))]
+ [(filter-phase-junks-after-commit? (car %traversing-list))
+ (begin
+ (display (string-append "<opensmtpd-filter-phase-configuration> fieldname 'decision' option \n"
+ "\"junk\" cannot junk an email during 'phase' \"commit\".\n"))
+ (throw 'bad! (car %traversing-list)))]
+ [else (loop (cdr %traversing-list) %original-list)])))]))
+
+(define (list-has-duplicates-or-non-filters? list)
+ (not (list-of-unique-filter-or-filter-phase? list)))
+
+(define (filter-phase-has-message-and-value? record)
+ (and (opensmtpd-filter-phase-configuration-message record)
+ (opensmtpd-filter-phase-configuration-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-configuration-decision record))
+ (if (string-in-list? 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-configuration-message record))
+ #t]
+ [(string? (opensmtpd-filter-phase-configuration-message record))
+ (let ((number (string->number
+ (substring
+ (opensmtpd-filter-phase-configuration-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-configuration-decision record))
+ (if (string=? "rewrite" decision)
+ (if (and (number? (opensmtpd-filter-phase-configuration-value record))
+ (eq? #f (opensmtpd-filter-phase-configuration-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
+ (string-in-list?
+ (opensmtpd-filter-phase-configuration-decision record)
+ (list "junk" "bypass"))
+ (or
+ (opensmtpd-filter-phase-configuration-value record)
+ (opensmtpd-filter-phase-configuration-message record))))
+
+(define (filter-phase-junks-after-commit? record)
+ (and (string=? (opensmtpd-filter-phase-configuration-decision record) "junk")
+ (string=? (opensmtpd-filter-phase-configuration-phase record) "commit")))
+
+;; returns #t if list is a unique list of <opensmtpd-filter-configuration> or <opensmtpd-filter-phase-configuration>
+;; returns # otherwise
+(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-configuration> or <opensmtpd-filter-configuration>
+ (primitive-eval
+ (cons 'and (map (lambda (filter)
+ (or (opensmtpd-filter-configuration? filter)
+ (opensmtpd-filter-phase-configuration? filter)))
+ %filters)))
+ (not (contains-duplicate? %filters))))
+
+(define (throw-error var %strings)
+ (display (apply string-append %strings))
+ (throw 'bad! var))
+
+;; this is used for sanitizing <opensmtpd-filter-phase-configuration> fieldname 'options'
+(define (contains-duplicate? list)
+ (if (null? list)
+ #f
+ (or
+ ;; check if (car list) is in (cdr list)
+ (primitive-eval (cons 'or
+ (map (lambda (var) (equal? var (car list)))
+ (cdr list))))
+ ;; check if (cdr list) contains duplicate
+ (contains-duplicate? (cdr list)))))
+
+;; 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-unique-opensmtpd-option-configuration? list)
+ (and (list-of-type?
+ list opensmtpd-option-configuration?)
+ (not (contains-duplicate? list))))
+
+(define (list-of-opensmtpd-ca-configuration? list)
+ (list-of-type? list opensmtpd-ca-configuration?))
+
+(define (list-of-opensmtpd-pki-configuration? list)
+ (list-of-type? list opensmtpd-pki-configuration?))
+
+(define (list-of-opensmtpd-listen-on-configuration? list)
+ (and (list-of-type? list opensmtpd-listen-on-configuration?)
+ (not (contains-duplicate? list))))
+
+(define (list-of-unique-opensmtpd-match-configuration? list)
+ (and (list-of-type? list opensmtpd-match-configuration?)
+ (not (contains-duplicate? list))))
+
+(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))
+
+;; at the moment I cannot define this by using list-of-type?
+;; the first (not (null? assoc-list)) prevents that.
+(define (assoc-list? assoc-list)
+ (list-of-type? assoc-list (lambda (pair)
+ (if (and (pair? pair)
+ (string? (car pair))
+ (string? (cdr pair)))
+ #t
+ #f))))
+
+(define* (variable->string var #:key (append "") (postpend " "))
+ (let ([var (if (number? var)
+ (number->string var)
+ var)])
+ (if var
+ (string-append append var postpend)
+ "")))
+
+;; this procedure takes in one argument.
+;; if that argument is an <opensmtpd-table-configuration> whose fieldname 'values' is an assoc-list, then it returns
+;; #t, #f if otherwise.
+;; TODO should I remove these two functions? And instead use the (opensmtpd-table-configuration-type) procedure?
+(define (table-whose-data-are-assoc-list? table)
+ (if (not (opensmtpd-table-configuration? table))
+ #f
+ (assoc-list? (opensmtpd-table-configuration-data table))))
+
+;; this procedure takes in one argument
+;; if that argument is an <opensmtpd-table-configuration> whose fieldname 'values' is a list of strings, then it returns
+;; #t, #f if otherwise.
+(define (table-whose-data-are-a-list-of-strings? table)
+ (if (not (opensmtpd-table-configuration? table))
+ #f
+ (list-of-strings? (opensmtpd-table-configuration-data table))))
+
+;; 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)
+(define (opensmtpd-table-configuration->string table)
+ (string-append "table " (opensmtpd-table-configuration-name table) " "
+ (let ([type (opensmtpd-table-configuration-type table)])
+ (cond [(eq? type (quote list-of-strings))
+ (string-append "{ " (list-of-strings->string (opensmtpd-table-configuration-data table)
+ #:append "\""
+ #:drop-right-number 3
+ #:postpend "\"") " }")]
+ [(eq? type (quote assoc-list))
+ (string-append "{ " (assoc-list->string (opensmtpd-table-configuration-data table)) " }")]
+ [(eq? type (quote db))
+ (string-append "db:" (opensmtpd-table-configuration-data table))]
+ [(eq? type (quote file))
+ (string-append "file:" (opensmtpd-table-configuration-data table))]
+ [else (throw 'youMessedUp table)]))
+ " \n"))
+
+;; The following functions convert various records into strings.
+
+(define (opensmtpd-listen-on-configuration->string record)
+ (string-append "listen on "
+ (opensmtpd-listen-on-configuration-interface record) " "
+ (let* ([hostname (opensmtpd-listen-on-configuration-hostname record)]
+ [hostnames (if (opensmtpd-listen-on-configuration-hostnames record)
+ (opensmtpd-table-configuration-name (opensmtpd-listen-on-configuration-hostnames record))
+ #f)]
+ [filters (opensmtpd-listen-on-configuration-filters record)]
+ [filter-name (if filters
+ (if (< 1 (length filters))
+ (generate-filter-chain-name filters)
+ (if (opensmtpd-filter-configuration? (car filters))
+ (opensmtpd-filter-configuration-name (car filters))
+ (opensmtpd-filter-phase-configuration-name (car filters))))
+ #f)]
+ [mask-src (opensmtpd-listen-on-configuration-mask-src record)]
+ [tag (opensmtpd-listen-on-configuration-tag record)]
+ [secure-connection (opensmtpd-listen-on-configuration-secure-connection record)]
+ [port (opensmtpd-listen-on-configuration-port record)]
+ [pki (opensmtpd-listen-on-configuration-pki record)]
+ [auth (opensmtpd-listen-on-configuration-auth record)]
+ [auth-optional (opensmtpd-listen-on-configuration-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 "])
+ "")
+ (variable->string port #:append "port " #:postpend " ")
+ (if pki
+ (variable->string (opensmtpd-pki-configuration-domain pki) #:append "pki ")
+ "")
+ (if auth
+ (string-append "auth "
+ (if (opensmtpd-table-configuration? auth)
+ (string-append "<" (opensmtpd-table-configuration-name auth) "> ")
+ ""))
+ "")
+ (if auth-optional
+ (string-append "auth-optional "
+ (if (opensmtpd-table-configuration? auth-optional)
+ (string-append "<" (opensmtpd-table-configuration-name auth-optional) "> ")
+ ""))
+ "")
+ "\n"))))
+
+(define (opensmtpd-listen-on-socket-configuration->string record)
+ (string-append "listen on socket "
+ (let* ([filters (opensmtpd-listen-on-socket-configuration-configuration-filters record)]
+ [filter-name (if filters
+ (if (< 1 (length filters))
+ (generate-filter-chain-name filters)
+ (if (opensmtpd-filter-configuration? (car filters))
+ (opensmtpd-filter-configuration-name (car filters))
+ (opensmtpd-filter-phase-configuration-name (car filters))))
+ #f)]
+ [mask-src (opensmtpd-listen-on-socket-configuration-configuration-mask-src record)]
+ [tag (opensmtpd-listen-on-socket-configuration-configuration-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-action-relay-configuration->string record)
+ (let ([backup (opensmtpd-action-relay-configuration-backup record)]
+ [backup-mx (opensmtpd-action-relay-configuration-backup-mx record)]
+ [helo (opensmtpd-action-relay-configuration-helo record)]
+ ;; helo-src can either be a string IP address or an <opensmtpd-table-configuration>
+ [helo-src (if (opensmtpd-action-relay-configuration-helo-src record)
+ (if (string? (opensmtpd-action-relay-configuration-helo-src record))
+ (opensmtpd-action-relay-configuration-helo-src record)
+ (string-append "<\""
+ (opensmtpd-table-configuration-name
+ (opensmtpd-action-relay-configuration-src record))
+ "\">"))
+ #f)]
+ [domain (if (opensmtpd-action-relay-configuration-domain record)
+ (opensmtpd-table-configuration-name
+ (opensmtpd-action-relay-configuration-domain record))
+ #f)]
+ [host (opensmtpd-action-relay-configuration-host record)]
+ [name (opensmtpd-action-relay-configuration-name record)]
+ [pki (if (opensmtpd-action-relay-configuration-pki record)
+ (opensmtpd-pki-configuration-domain (opensmtpd-action-relay-configuration-pki record))
+ #f)]
+ [srs (opensmtpd-action-relay-configuration-srs record)]
+ [tls (opensmtpd-action-relay-configuration-tls record)]
+ [auth (if (opensmtpd-action-relay-configuration-auth record)
+ (opensmtpd-table-configuration-name
+ (opensmtpd-action-relay-configuration-auth record))
+ #f)]
+ [mail-from (opensmtpd-action-relay-configuration-mail-from record)]
+ ;; src can either be a string IP address or an <opensmtpd-table-configuration>
+ [src (if (opensmtpd-action-relay-configuration-src record)
+ (if (string? (opensmtpd-action-relay-configuration-src record))
+ (opensmtpd-action-relay-configuration-src record)
+ (string-append "<\""
+ (opensmtpd-table-configuration-name
+ (opensmtpd-action-relay-configuration-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-configuration->string record)
+ (string-append "lmtp "
+ (opensmtpd-lmtp-configuration-destination record)
+ (if (opensmtpd-lmtp-configuration-rcpt-to record)
+ (begin
+ " " (opensmtpd-lmtp-configuration-rcpt-to record))
+ "")))
+
+(define (opensmtpd-mda-configuration->string record)
+ (string-append "mda "
+ (opensmtpd-mda-configuration-command record) " "))
+
+(define (opensmtpd-maildir-configuration->string record)
+ (string-append "maildir "
+ "\""
+ (if (opensmtpd-maildir-configuration-pathname record)
+ (opensmtpd-maildir-configuration-pathname record)
+ "~/Maildir")
+ "\""
+ (if (opensmtpd-maildir-configuration-junk record)
+ " junk "
+ " ")))
+
+(define (opensmtpd-action-local-delivery-configuration->string record)
+ (let ([name (opensmtpd-action-local-delivery-configuration-name record)]
+ [method (opensmtpd-action-local-delivery-configuration-method record)]
+ [alias (if (opensmtpd-action-local-delivery-configuration-alias record)
+ (opensmtpd-table-configuration-name
+ (opensmtpd-action-local-delivery-configuration-alias record))
+ #f)]
+ [ttl (opensmtpd-action-local-delivery-configuration-ttl record)]
+ [user (opensmtpd-action-local-delivery-configuration-user record)]
+ [userbase (if (opensmtpd-action-local-delivery-configuration-userbase record)
+ (opensmtpd-table-configuration-name
+ (opensmtpd-action-local-delivery-configuration-userbase record))
+ #f)]
+ [virtual (if (opensmtpd-action-local-delivery-configuration-virtual record)
+ (opensmtpd-table-configuration-name
+ (opensmtpd-action-local-delivery-configuration-virtual record))
+ #f)]
+ [wrapper (opensmtpd-action-local-delivery-configuration-wrapper record)])
+ (string-append
+ "\"" name "\" "
+ (cond [(string? method)
+ (string-append method " ")]
+ [(opensmtpd-mda-configuration? method)
+ (opensmtpd-mda-configuration->string method)]
+ [(opensmtpd-lmtp-configuration? method)
+ (opensmtpd-lmtp-configuration->string method)]
+ [(opensmtpd-maildir-configuration? method)
+ (opensmtpd-maildir-configuration->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-action-local-delivery-configuration and
+;; opensmtpd-action-relay-configuration into strings.
+(define (opensmtpd-action->string record)
+ (string-append "action "
+ (cond [(opensmtpd-action-local-delivery-configuration? record)
+ (opensmtpd-action-local-delivery-configuration->string record)]
+ [(opensmtpd-action-relay-configuration? record)
+ (opensmtpd-action-relay-configuration->string record)])
+ " \n"))
+
+;; this turns option records found in <opensmtpd-match-configuration> into strings.
+(define* (opensmtpd-option-configuration->string record
+ #:key
+ (space-after-! #f))
+ (let ([not (opensmtpd-option-configuration-not record)]
+ [option (opensmtpd-option-configuration-option record)]
+ [regex (opensmtpd-option-configuration-regex record)]
+ [data (opensmtpd-option-configuration-data record)])
+ (string-append
+ (if not
+ (if space-after-!
+ "! "
+ "!")
+ "")
+ option " "
+ (if regex
+ "regex "
+ "")
+ (if data
+ (if (opensmtpd-table-configuration? data)
+ (string-append "<" (opensmtpd-table-configuration-name data) "> ")
+ (string-append data " "))
+ ""))))
+
+(define (opensmtpd-match-configuration->string record)
+ (string-append "match "
+ (let* ([action (opensmtpd-match-configuration-action record)]
+ [name (cond [(opensmtpd-action-relay-configuration? action)
+ (opensmtpd-action-relay-configuration-name action)]
+ [(opensmtpd-action-local-delivery-configuration? action)
+ (opensmtpd-action-local-delivery-configuration-name action)]
+ [else 'reject])]
+ [options (opensmtpd-match-configuration-options record)])
+ (string-append
+ (if options
+ (apply string-append
+ (map opensmtpd-option-configuration->string options))
+ "")
+ (if (string? name)
+ (string-append "action " "\"" name "\" ")
+ "reject ")
+ "\n"))))
+
+(define (opensmtpd-ca-configuration->string record)
+ (string-append "ca " (opensmtpd-ca-configuration-name record) " "
+ "cert \"" (opensmtpd-ca-configuration-file record) "\"\n"))
+
+(define (opensmtpd-pki-configuration->string record)
+ (let ([domain (opensmtpd-pki-configuration-domain record)]
+ [cert (opensmtpd-pki-configuration-cert record)]
+ [key (opensmtpd-pki-configuration-key record)]
+ [dhe (opensmtpd-pki-configuration-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-configuration? filter)
+ (opensmtpd-filter-configuration-name filter)
+ (opensmtpd-filter-phase-configuration-name filter))
+ "-"))
+ list-of-filters)))
+ 1))
+
+;; this procedure takes in a list of <opensmtpd-filter-configuration> and <opensmtpd-filter-phase-configuration>,
+;; returns a string of the form:
+;; filter "uniquelyGeneratedName" 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-configuration? filter)
+ (opensmtpd-filter-configuration-name filter)
+ (opensmtpd-filter-phase-configuration-name filter))
+ "\", "))
+ list-of-filters))
+ ) 2)
+ "}\n"))
+
+(define (opensmtpd-filter-phase-configuration->string record)
+ (let ([name (opensmtpd-filter-phase-configuration-name record)]
+ [phase (opensmtpd-filter-phase-configuration-phase record)]
+ [decision (opensmtpd-filter-phase-configuration-decision record)]
+ [options (opensmtpd-filter-phase-configuration-options record)]
+ [message (opensmtpd-filter-phase-configuration-message record)]
+ [value (opensmtpd-filter-phase-configuration-value record)])
+ (string-append "filter "
+ "\"" name "\" "
+ "phase " phase " "
+ "match "
+ (apply string-append ; turn the options into a string
+ (flatten
+ (map (lambda (option)
+ (opensmtpd-option-configuration->string option #:space-after-! #f))
+ options)))
+ " "
+ decision " "
+ (if (string-in-list? decision (list "reject" "disconnect"))
+ (string-append "\"" message "\"")
+ "")
+ (if (string=? "rewrite" decision)
+ (string-append "rewrite " (number->string value))
+ "")
+ "\n")))
+
+;; filters elements may be <opensmtpd-filter-configuration>, <opensmtpd-filter-phase-configuration>,
+;; and lists that look like (list (opensmtpd-filter-configuration...) (opensmtpd-filter-phase-configuration ...)
+;; ...)
+;; this function converts it to a string.
+;; Consider if a user passed in a valid <opensmtpd-configuration>, whose total valid filters
+;; so that (get-opensmtpd-filters (opensmtpd-configuration)) returns
+;; look like this: (we will call this list "total filters"):
+;; (list (opensmtpd-filter
+;; (name "rspamd")
+;; (proc "rspamd"))
+;; (list (opensmtpd-filter-phase-configuration ; this is a listen-on, with a filter-chain.
+;; (name "dkimsign")
+;; ...)
+;; (opensmtpd-filter
+;; (name "rspamd")
+;; (proc "rspamd"))))
+;;
+;; did you notice that filter "rspamd" is listed twice? How do you make sure that it is NOT
+;; printed twice in smtpd.conf?
+;; 1st flatten "total filters", then remove its duplicates. Then print all of those filters.
+;; 2nd now we go through "total filters", and we only print the non-filter-chains.
+(define (opensmtpd-filters->string filters)
+ ;; first display the unique <opensmtpd-filter-configuration>s. and <opensmtpd-filter-phase-configuration>s.
+ ;; to do this: flatten filters, then remove duplicates.
+ (string-append
+ (apply string-append
+ (map (lambda (filter)
+ (cond ((opensmtpd-filter-phase-configuration? filter)
+ (opensmtpd-filter-phase-configuration->string filter))
+ (else ; you are a <opensmtpd-filter-configuration>
+ (string-append "filter "
+ "\"" (opensmtpd-filter-configuration-name filter) "\" "
+ (if (opensmtpd-filter-exec filter)
+ "proc-exec "
+ "proc ")
+ "\"" (opensmtpd-filter-configuration-proc filter) "\""
+ "\n"))))
+ (delete-duplicates (flatten filters))))
+ ;; now we have to print the filter chains.
+ (apply string-append
+ (remove boolean?
+ (map (lambda (filter)
+ (cond ((list? filter)
+ (opensmtpd-filter-chain->string filter))
+ (else ; you are a <opensmtpd-filter-configuration>
+ #f)))
+ filters)))))
+
+(define (opensmtpd-configuration-listen->string string)
+ (string-append
+ "include \"" string "\"\n"))
+
+(define (opensmtpd-configuration-srs->string record)
+ (let ([key (opensmtpd-srs-configuration-key record)]
+ [backup-key (opensmtpd-srs-configuration-backup-key record)]
+ [ttl-delay (opensmtpd-srs-configuration-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-configuration->string record)
+ (let ([ciphers (opensmtpd-smtp-configuration-ciphers record)]
+ [limit-max-mails (opensmtpd-smtp-configuration-limit-max-mails record)]
+ [limit-max-rcpt (opensmtpd-smtp-configuration-limit-max-rcpt record)]
+ [max-message-size (opensmtpd-smtp-configuration-max-message-size record)]
+ [sub-addr-delim (opensmtpd-smtp-configuration-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-configuration-compression record)]
+ [encryption (opensmtpd-queue-configuration-encryption record)]
+ [ttl-delay (opensmtpd-queue-configuration-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-configuration>.
+;; Each <opensmtpd-match-configuration> 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-configuration-action (car list))
+ (loop (cdr list))))))
+ (delete-duplicates (append opensmtpd-actions)))
+
+;; build a list of opensmtpd-pki-configurations from
+;; opensmtpd-configuration-listen-ons and
+;; get-opensmtpd-actions
+(define (get-opensmtpd-pki-configurations record)
+ ;; TODO/FIXME/maybe/wishlist could get-opensmtpd-actions -> NOT have an opensmtpd-action-relay-configuration?
+ ;; 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-action-relay-configuration? (car list))
+ (opensmtpd-action-relay-configuration-pki (car list)))
+ (cons (opensmtpd-action-relay-configuration-pki (car list))
+ (loop1 (cdr list)))
+ (loop1 (cdr list))))))
+ ;; FIXME/TODO/maybe/wishlist
+ ;; this could be #f aka left blank. aka there are no listen-ons 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-listen-ons record)])
+ (if (null? list)
+ '()
+ (if (opensmtpd-listen-on-configuration-pki (car list))
+ (cons (opensmtpd-listen-on-configuration-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-configuration>,
+;; <opensmtpd-filter-phase-configuration>, and a filter-chain.
+;; It returns a list of <opensmtpd-filter-configuration> and/or <opensmtpd-filter-phase-configuration>
+;; here's an example of what this procedure might return:
+;; (list (opensmtpd-filter-configuration...) (opensmtpd-filter-phase-configuration ...)
+;; (openmstpd-filter ...) (opensmtpd-filter-phase-configuration ...)
+;; ;; this next list is a filter-chain.
+;; (list (opensmtpd-filter-phase-configuration ...) (opensmtpd-filter-configuration...)))
+;;
+;; This procedure handles filter chains a little odd.
+(define (get-opensmtpd-filters record)
+ (define list-of-listen-on-records (if (opensmtpd-configuration-listen-ons record)
+ (opensmtpd-configuration-listen-ons record)
+ '()))
+
+ (define listen-on-socket-filters
+ (if (opensmtpd-listen-on-socket-configuration-configuration-filters (opensmtpd-configuration-listen-on-socket record))
+ (opensmtpd-listen-on-socket-configuration-configuration-filters (opensmtpd-configuration-listen-on-socket record))
+ '()))
+
+ (delete-duplicates
+ (append (remove boolean?
+ (map-in-order (lambda (listen-on-record) ; get the filters found in the <listen-on-record>s
+ (if (and (opensmtpd-listen-on-configuration-filters listen-on-record)
+ (= 1 (length (opensmtpd-listen-on-configuration-filters
+ listen-on-record))))
+ (car (opensmtpd-listen-on-configuration-filters listen-on-record))
+ (opensmtpd-listen-on-configuration-filters listen-on-record)))
+ list-of-listen-on-records))
+ listen-on-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-configuration>s assuming the thing you passed into it had
+;; any <opensmtpd-table-configuration>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-configuration? 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)))))])))
+
+
+;; 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)
+ ;; 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)))))
+
+ ;;(mixed-text-file "opensmtpd.conf")
+ (string-append
+ ;; write out the includes
+ (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-includes
+ opensmtpd-configuration-listen->string)
+ (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-configuration->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-configuration->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->string (get-opensmtpd-filters record))
+ ;; write out all the cas
+ (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-cas opensmtpd-ca-configuration->string)
+ ;; write out all the pkis
+ (opensmtpd-configuration-fieldname->string record get-opensmtpd-pki-configurations opensmtpd-pki-configuration->string)
+ ;; write all of the listen-on-records
+ (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-listen-ons
+ opensmtpd-listen-on-configuration->string)
+ (opensmtpd-configuration-fieldname->string record opensmtpd-configuration-listen-on-socket
+ opensmtpd-listen-on-socket-configuration->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-configuration->string)))
+
(define %default-opensmtpd-config-file
(plain-file "smtpd.conf" "