Openmstpd-configuration may only be configured by a config-file. This patch, enables one to configure opensmtpd by using some guile record types (defined via define-record-type*). This patch is mostly complete, but I could use some guidance on what else needs to be done for it to be accepted in to guix properly. I do have some documentation written for the opensmtpd-service, but it is probably not complete and is currently written in the org-mode format. * gnu/services/mail.scm (opensmtpd-table-configuration): New record. * gnu/services/mail.scm (opensmtpd-ca-configuration): New record. * gnu/services/mail.scm (opensmtpd-pki-configuration): New record. * gnu/services/mail.scm (opensmtpd-action-local-delivery-configuration): New record. * gnu/services/mail.scm (opensmtpd-maildir-configuration): New record. * gnu/services/mail.scm (opensmtpd-mda-configuration): New record. * gnu/services/mail.scm (opensmtpd-action-relay-configuration): New record. * gnu/services/mail.scm (opensmtpd-option-configuration): New record. * gnu/services/mail.scm (opensmtpd-filter-phase-configuration): New record. * gnu/services/mail.scm (opensmtpd-filter-configuration): New record. * gnu/services/mail.scm (opensmtpd-listen-on-configuration): New record. * gnu/services/mail.scm (opensmtpd-listen-on-socket-configuration): New record. * gnu/services/mail.scm (opensmtpd-match-configuration): New record. * gnu/services/mail.scm (opensmtpd-smtp-configuration): New record. * gnu/services/mail.scm (opensmtpd-srs-configuration): New record. * gnu/services/mail.scm (opensmtpd-queue-configuration): New record. * gnu/services/mail.scm (opensmtpd-configuration): New record. --- gnu/services/mail.scm | 2016 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 2013 insertions(+), 3 deletions(-) diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index d99743ac31..bdc0ee3bf7 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -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 record, "] + [(eq? opensmtpd-table-configuration? (car procedures)) + "an record, "] + [(eq? list-of-unique-opensmtpd-match-configuration? (car procedures)) + "a list of unique records, "] + [(eq? table-whose-data-are-assoc-list? (car procedures)) + (string-append + "an 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 support have a fieldname 'file'? +;; Or should I change name to name-or-file ? +(define-record-type* + 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 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 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 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 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 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 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 " fieldname 'method' must be of type \n" + "\"mbox\", \"expand-only\", \"forward-only\" \n" + ", , \n" + "or .\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 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 "" or "" + ;; 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 & +;; +(define-record-type* + 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 " 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 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 + ;; " 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 " 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 + (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 + ;; return #t if 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 + (cond [(list-has-duplicates-or-non-opensmtpd-option-configuration var) + (begin + (display (string-append " fieldname: 'options' is a list of unique \n" + " 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 "'s fieldname 'option' values of \n" + "'src', 'helo', 'mail-from', or 'rcpt-to' need a corresponding 'table' \n" + " of type . 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 + ;; , 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 " 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 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 and . +;; 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 or +;; 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 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 " 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 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 " 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 make-opensmtpd-listen-on-socket-configuration-configuration + opensmtpd-listen-on-socket-configuration-configuration? + ;; false or or list of + (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 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 " fieldname 'action' is of type , \n" + ", 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 '(" fieldname 'options' is a list of unique \n" + " records. \n"))) + (else (sanitize-list-of-options-for-match-configuration var))))))) + +(define-record-type* + 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 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 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 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 . + (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 " fieldname 'listen-ons' expects a list of records ") + (display "of one or more unique records.\n") + (throw 'bad! var)))))) + ;; accepts type + (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 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 "'s fieldname 'options' has two\n" + (string-append " 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 " with fieldname 'option' with value 'helo' \n" + "must have a 'data' of type string or .\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 " with fieldname 'option' with value 'mail-from' \n" + "must have a 'data' of type string or .\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 " with fieldname 'option' with value 'rcpt-to' \n" + "must have a 'data' of type string or .\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 " 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 " 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 + `("'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 '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 's fieldname 'options' value is 'for domain' \n" + "or 'for rcpt-to', then its 'data' field must be a string or an \n" + " 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 + `("'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 '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 's fieldname 'options' value is 'from mail-from' \n" + "or 'from src', then its 'data' field must be a string or an \n" + " record.\n"))) + (else (loop (cdr %traversing-options) (alist-cons "from" option-record %sanitized-options))))]))))) + +;; some procedures for and +;; . +(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 " fieldname: 'filters' is a list, in which each unique element \n" + "is of type or .\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 " 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 " 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 " 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 " 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 " 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 or +;; returns # otherwise +(define (list-of-unique-filter-or-filter-phase? %filters) + (and (list? %filters) + (not (null? %filters)) + ;; this list is made up of only or + (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 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 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 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
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 + [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 + [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 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 and , +;; 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 , , +;; 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 , 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 s. and 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 + (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 + #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 from +;; opensmtpd-configuration-matches, which is a list of . +;; Each has a fieldname 'action', which accepts an . +(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 and returns a list whose elements are , +;; , and a filter-chain. +;; It returns a list of and/or +;; 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 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 s assuming the thing you passed into it had +;; any 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" " -- 2.36.1