[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#56046] [Patch master v2] services (opensmtpd): add opensmtpd record
|
From: |
Joshua Branson |
|
Subject: |
[bug#56046] [Patch master v2] services (opensmtpd): add opensmtpd records to enhance opensmtpd-configuration. |
|
Date: |
Mon, 24 Oct 2022 13:30:07 -0400 |
This is a V2 patch. I've added some tests that help test for various
ways that users could accidentally misconfigure their configuration.
I probably need to make those error messages, use
(guix diagnostics). Currently compiling the tests, auto runs them.
So "make" auto runs the tests. Also their error messages are output
to the terminal, and I'm not sure how to turn that off.
tl;dr this is a WIP patch, and I just wanted to submit something,
because I keep finding more things that I need to fix.
The task list as always is here:
https://notabug.org/jbranso/linode-guix-system-configuration/src/master/opensmtpd.org
Openmstpd-configuration may only be configured by a config-file that
uses the smtpd.conf syntax. This patch, enables one to configure
opensmtpd by using record types.
* gnu/services/mail.scm:
(opensmtpd-table-configuration,
opensmtpd-ca-configuration,
opensmtpd-pki-configuration,
opensmtpd-action-local-delivery-configuration,
opensmtpd-maildir-configuration,
opensmtpd-mda-configuration,
opensmtpd-action-relay-configuration,
opensmtpd-option-configuration,
opensmtpd-filter-phase-configuration,
opensmtpd-filter-configuration,
opensmtpd-interface,
opensmtpd-socket,
opensmtpd-match-configuration,
opensmtpd-smtp-configuration,
opensmtpd-srs-configuration,
opensmtpd-queue-configuration, and
opensmtpd-configuration): New records.
(false?, is-value-right-type, add-comma-or-string,
list-of-procedures->string, string-in-list?, my-sanitize,
opensmtpd-filter-chain?, throw-error-duplicate-option,
sanitize-list-of-options-for-match-configuration, sanitize-filters,
list-has-duplicates-or-non-filters?,
filter-phase-has-message-and-value?,
filter-phase-decision-lacks-proper-message?,
filter-phase-lacks-proper-value?,
filter-phase-has-incorrect-junk-or-bypass?,
filter-phase-junks-after-commit?,
list-of-unique-filter-or-filter-phase?, throw-error,
contains-duplicate?, list-of-type?, list-of-strings?,
list-of-unique-opensmtpd-option-configuration?,
list-of-opensmtpd-ca-configuration?,
list-of-opensmtpd-pki-configuration?,
list-of-opensmtpd-listen-on-configuration?,
list-of-unique-opensmtpd-match-configuration?, list-of-strings->string,
assoc-list? assoc-list, variable->string,
table-whose-data-are-assoc-list?,
table-whose-data-are-a-list-of-strings?, assoc-list->string,
opensmtpd-table-configuration->string,
opensmtpd-listen-on-configuration->string,
opensmtpd-listen-on-socket-configuration->string,
opensmtpd-action-relay-configuration->string,
opensmtpd-lmtp-configuration->string,
opensmtpd-mda-configuration->string,
opensmtpd-maildir-configuration->string,
opensmtpd-action-local-delivery-configuration->string,
opensmtpd-action->string, opensmtpd-option-configuration->string,
opensmtpd-match-configuration->string,
opensmtpd-ca-configuration->string, opensmtpd-pki-configuration->string,
generate-filter-chain-name, opensmtpd-filter-chain->string,
opensmtpd-filter-phase-configuration->string, opensmtpd-filters->string,
opensmtpd-configuration-listen->string,
opensmtpd-configuration-srs->string,
opensmtpd-smtp-configuration->string,
opensmtpd-configuration-queue->string, get-opensmtpd-actions,
get-opensmtpd-pki-configurations, get-opensmtpd-filters, flatten,
get-opensmtpd-tables, opensmtpd-configuration-fieldname->string,
list-of-records->string, opensmtpd-configuration->mixed-text-file): New
procedures.
* gnu/tests/mail.scm : new tests for various opensmtpd records.
* doc/guix.texi (OpenSMTPD Service): Added documentation for the
new records for opensmtpd.
---
doc/guix.texi | 1054 ++++++++++++++++++++-
gnu/services/mail.scm | 2085 ++++++++++++++++++++++++++++++++++++++++-
gnu/tests/mail.scm | 355 +++++++
3 files changed, 3475 insertions(+), 19 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 535c8cdfc3..c80f3e9d76 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25409,14 +25409,59 @@ could instantiate a dovecot service like this:
@subsubheading OpenSMTPD Service
@deffn {Scheme Variable} opensmtpd-service-type
-This is the type of the @uref{https://www.opensmtpd.org, OpenSMTPD}
-service, whose value should be an @code{opensmtpd-configuration} object
-as in this example:
-
-@lisp
-(service opensmtpd-service-type
- (opensmtpd-configuration
- (config-file (local-file "./my-smtpd.conf"))))
+OpenSMTPD is an easy-to-use mail transfer agent (MTA). Its configuration file
is
+throughly documented in @code{man 5 smtpd.conf}. OpenSMTPD @strong{listens}
for incoming
+mail and @strong{matches} the mail to @strong{actions}. The following records
represent those
+stages:
+
+@multitable {aaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item @strong{listens}
+@tab @code{<opensmtpd-interface>}
+@item
+@tab @code{<opensmtpd-socket>}
+@item
+@tab
+@item @strong{matches}
+@tab @code{<opensmtpd-match>}
+@item
+@tab
+@item @strong{actions}
+@tab @code{<opensmtpd-local-delivery>}
+@item
+@tab @code{<opensmtpd-relay>}
+@end multitable
+
+Additionally, each @code{<opensmtpd-interface>} and
+@code{<opensmtpd-socket>} may use a list of
+@code{<opensmtpd-filter>}, and/or
+@code{<opensmtpd-filter-phase>} records to filter email/spam. Also
+numerous records' fieldnames use @code{<opensmtpd-table>} to hold lists
+or key value pairs of data.
+
+A simple example configuration is below:
+
+@lisp
+(let ((smtp.gnu.org (opensmtpd-pki
+ (domain "smtp.gnu.org")
+ (cert "file.cert")
+ (key "file.key"))))
+ (service opensmtpd-service-type
+ (opensmtpd-configuration
+ (listen-ons (list
+ (opensmtpd-interface
+ (pki smtp.gnu.org))
+ (opensmtpd-interface
+ (pki smtp.gnu.org)
+ (secure-connection "smtps"))))
+ (matches (list
+ (opensmtpd-match
+ (action
+ (opensmtpd-local-delivery
+ (name "local-delivery"))))
+ (opensmtpd-match
+ (action
+ (opensmtpd-relay
+ (name "relay")))))))))
@end lisp
@end deffn
@@ -25433,14 +25478,1007 @@ it listens on the loopback network interface, and
allows for mail from
users and daemons on the local machine, as well as permitting email to
remote servers. Run @command{man smtpd.conf} for more information.
+<<<<<<< HEAD
+@item @code{bounce} (default: @code{(list "4h")})
+
+@code{bounce} is a list of strings, which send warning messages to the envelope
+sender when temporary delivery failures cause a message to remain in the
+queue for longer than string delay. Each string delay parameter consists
+of a string beginning with a positive decimal integer and a unit 's', 'm', 'h',
+or 'd'. At most four delay parameters can be specified.
+
+@item @code{listen-ons} (default: @code{(list (opensmtpd-interface))})
+
+@code{listen-ons} is a list of @code{<opensmtpd-interface>} records.
+This list details what interfaces and ports OpenSMTPD listens on as well as
+other information.
+
+@item @code{listen-on-socket} (default: @code{(opensmtpd-socket)})
+
+Listens for incoming connections on the Unix domain socket.
+
+@item @code{includes} (default: @code{#f})
+
+@code{includes} is a list of string filenames. Each filename's contents is
+additional configuration that is inserted into the top of the configuration
+file.
+
+@item @code{matches} default:
+
+@lisp
+ (list (opensmtpd-match
+ (action (opensmtpd-local-delivery
+ (name "local")
+ (method "mbox")))
+ (for (opensmtpd-option
+ (option "for local"))))
+ (opensmtpd-match
+ (action (opensmtpd-relay
+ (name "outbound")))
+ (from (opensmtpd-option
+ (option "from local")))
+ (for (opensmtpd-option
+ (option "for any")))))
+@end lisp
+
+@code{matches} is a list of @code{<opensmtpd-match>} records, which
+matches incoming mail and sends it to a correspending action. The match
+records are evaluated sequentially, with the first match winning. If an
+incoming mail does not match any match records, then it is rejected.
+@c put this backin? @end itemize
+
+@c put this back in? @itemize
+@item @code{mta-max-deferred} (default: @code{100})
+
+When delivery to a given host is suspended due to temporary failures, cache
+at most number envelopes for that host such that they can be delivered as
+soon as another delivery succeeds to that host. The default is 100.
+
+@item @code{queue} (default: @code{#f})
+
+@code{queue} expects an @code{<opensmtpd-queue>} record. With it, one may
+compress and encrypt queue-ed emails as well as set the default expiration
+time for temporarily undeliverable messages.
+
+@item @code{smtp} (default: @code{#f})
+
+@code{smtp} expects an @code{<opensmtpd-smtp>} record, which lets one
+specifiy how large email may be along with other settings.
+
+@item @code{srs} (default: @code{#f})
+
+@code{srs} expects an @code{<opensmtpd-srs>} record, which lets one set
+up SRS, the Sender Rewritting Scheme.
+=======
@item @code{setgid-commands?} (default: @code{#t})
Make the following commands setgid to @code{smtpq} so they can be
executed: @command{smtpctl}, @command{sendmail}, @command{send-mail},
@command{makemap}, @command{mailq}, and @command{newaliases}.
@xref{Setuid Programs}, for more information on setgid programs.
+>>>>>>> origin/master
@end table
@end deftp
+@itemize
+@item
+Data Type: opensmtpd-interface
+
+Data type representing the configuration of an
+@code{<opensmtpd-interface>}. Listen on the fieldname @code{interface} for
+incoming connections, using the same syntax as for ifconfig(8). The interface
+parameter may also be an string interface group, an string IP address, or a
+string domain name. Listening can optionally be restricted to a specific
+address fieldname @code{family}, which can be either ``inet4'' or ``inet6''.
+
+@itemize
+@item @code{interface} (default: ``lo'')
+
+The string interface to listen for incoming connections. These interface can
+usually be found by the command @code{ip link}.
+
+@item @code{family} (default: @code{#f})
+
+The string IP family to use. Valid strings are ``inet4'' or ``inet6''.
+
+@item @code{auth} (default: @code{#f})
+
+Support SMTPAUTH: clients may only start SMTP transactions after successful
+authentication. If @code{auth} is @code{#t}, then users are authenticated
against
+their own normal login credentials. Alternatively @code{auth} may be an
+@code{<opensmtpd-table>} whose users are authenticated against
+their passwords.
+
+@item @code{auth-optional} (default: @code{#f})
+
+Support SMTPAUTH optionally: clients need not authenticate, but may do so.
+This allows the @code{<opensmtpd-interface>} to both accept
+incoming mail from untrusted senders and permit outgoing mail from
+authenticated users (using @code{<opensmtpd-match>} fieldname
+@code{auth}). It can be used in situations where it is not possible to listen
on
+a separate port (usually the submission port, 587) for users to
+authenticate.
+
+@item @code{filters} (default: @code{#f})
+
+A list of one or many @code{<opensmtpd-filter>} or
+@code{<opensmtpd-filter-phase>} records. The filters are applied
+sequentially. These records listen and filter on connections handled by this
+listener.
+
+@item @code{hostname} (default: @code{#f})
+
+Use string ``hostname'' in the greeting banner instead of the default server
+name.
+
+@item @code{hostnames} (default: @code{#f})
+
+Override the server name for specific addresses. Use a
+@code{<opensmtpd-table>} containing a mapping of string IP
+addresses to hostnames. If the address on which the connection arrives
+appears in the mapping, the associated hostname is used.
+
+@item @code{mask-src} (default: @code{#f})
+
+If @code{#t}, then omit the from part when prepending ???Received??? headers.
+
+@item @code{disable-dsn} (default: @code{#f})
+
+When @code{#t}, then disable the DSN (Delivery Status Notification) extension.
+
+@item @code{pki} (default: @code{#f})
+
+For secure connections, use an @code{<opensmtpd-pki>}
+to prove a mail server's identity.
+
+@item @code{port} (default: @code{#f})
+
+Listen on the integer port instead of the default port of 25.
+
+@item @code{proxy-v2} (default: @code{#f})
+
+If @code{#t}, then support the PROXYv2 protocol, rewriting appropriately source
+address received from proxy.
+
+@item @code{received-auth} (default: @code{#f})
+
+If @code{#t}, then in ???Received??? headers, report whether the session was
+authenticated and by which local user.
+
+@item @code{senders} (default: @code{#f})
+
+Look up the authenticated user in the supplied
+@code{<opensmtpd-table>} to find the email addresses that user is
+allowed to submit mail as.
+
+@item @code{secure-connection} (default: @code{#f})
+
+This is a string of one of these options:
+
+@multitable {aaaaaaaaaaaaaaaaaaaa}
{aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item ``smtps''
+@tab Support SMTPS, by default on port 465.
+@item ``tls''
+@tab Support STARTTLS, by default on port 25.
+@item ``tls-require-verify''
+@tab Like tls, but force clients to establish
+@item
+@tab a secure connection before being allowed to
+@item
+@tab start an SMTP transaction. With the verify
+@item
+@tab option, clients must also provide a valid
+@item
+@tab certificate to establish an SMTP session.
+@end multitable
+
+@item @code{tag} (default: @code{#f})
+
+Clients connecting to the listener are tagged with the given string tag.
+@end itemize
+
+@item Data Type: opensmtpd-socket
+
+Data type representing the configuration of an
+@code{<opensmtpd-socket>}. Listen for incoming SMTP
+connections on the Unix domain socket @samp{/var/run/smtpd.sock}. This is done
by
+default, even if the directive is absent.
+
+@itemize
+@item @code{filters} (default: @code{#f})
+
+A list of one or many @code{<opensmtpd-filter>} or
+@code{<opensmtpd-filter-phase>} records. These filter incoming
+connections handled by this listener.
+
+@item @code{mask-src} (default: @code{#f})
+
+If @code{#t}, then omit the from part when prepending ???Received??? headers.
+
+@item @code{tag} (default: @code{#f})
+
+Clients connecting to the listener are tagged with the given string tag.
+@end itemize
+
+@item Data Type: opensmtpd-match
+
+This data type represents the configuration of an
+@code{<opensmtpd-match>} record.
+
+If at least one mail envelope matches the options of one match record, receive
+the incoming message, put a copy into each matching envelope, and atomically
+save the envelopes to the mail spool for later processing by the respective
+@code{<opensmtpd-action>} found in fieldname @code{action}.
+
+@itemize
+@item @code{action} (default: @code{#f})
+
+If mail matches this match configuration, then do this action. Valid values
+include @code{<opensmtpd-local-delivery>} or
+@code{<opensmtpd-relay>}.
+
+@item @code{options} (default: @code{#f}) @code{<opensmtpd-option>}
+The fieldname 'option' is a list of unique
+@code{<opensmtpd-option>} records.
+
+Each @code{<opensmtpd-option>} record's fieldname 'option' has some
+mutually exclusive options: there can be only one ``for'' and only one
``from'' option.
+
+@multitable {aaaaaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@headitem for
+@tab from
+@item only use one of the following:
+@tab only use one of the following:
+@item ``for any''
+@tab ``from any''
+@item ``for local''
+@tab ``from auth''
+@item ``for domain''
+@tab ``from local''
+@item ``for rcpt-to''
+@tab ``from mail-from''
+@item
+@tab ``from socket''
+@item
+@tab ``from src''
+@end multitable
+
+The following matching options are supported and can all be negated (via not
+#t). The options that support a table (anything surrounded with '<' and '>'
+eg: <table>), also support specifying regex via (regex #t).
+
+@itemize
+@item @samp{for any}
+
+Specify that session may address any destination.
+
+@item @samp{for local}
+
+Specify that session may address any local domain. This is the default,
+and may be omitted.
+
+@item @samp{for domain _domain_ | <domain>}
+
+Specify that session may address the string or list table domain.
+
+@item @samp{for rcpt-to _recipient_ | <recipient>}
+
+Specify that session may address the string or list table recipient.
+
+@item @samp{from any}
+
+Specify that session may originate from any source.
+
+@item @samp{from auth}
+
+Specify that session may originate from any authenticated user, no matter
+the source IP address.
+
+@item @samp{from auth _user_ | <user>}
+
+Specify that session may originate from authenticated user or user list
+user, no matter the source IP address.
+
+@item @samp{from local}
+
+Specify that session may only originate from a local IP address, or from
+the local enqueuer. This is the default, and may be omitted.
+
+@item @samp{from mail-from _sender_ | <sender>}
+
+Specify that session may originate from sender or table sender, no
+matter the source IP address.
+
+@item @samp{from rdns}
+
+Specify that session may only originate from an IP address that resolves
+to a reverse DNS@.
+
+@item @samp{from rdns _hostname_ | <hostname>}
+
+Specify that session may only originate from an IP address that resolves
+to a reverse DNS matching string or list string hostname.
+
+@item @samp{from socket}
+
+Specify that session may only originate from the local enqueuer.
+
+@item @samp{from src _address_ | <address>}
+
+Specify that session may only originate from string or list table address
+which can be a specific address or a subnet expressed in CIDR-notation.
+
+@item @samp{auth}
+
+Matches transactions which have been authenticated.
+
+@item @samp{auth _username_ | <username>}
+
+Matches transactions which have been authenticated for user or user list
+username.
+
+@item @samp{helo _helo-name_ | <helo-name>}
+
+Specify that session's HELO / EHLO should match the string or list table
+helo-name.
+
+@item @samp{mail-from _sender_ | <sender>}
+
+Specify that transactions's MAIL FROM should match the string or list
+table sender.
+
+@item @samp{rcpt-to _recipient_ | <recipient>}
+
+Specify that transaction's RCPT TO should match the string or list table
+recipient.
+
+@item @samp{tag tag}
+Matches transactions tagged with the given tag.
+
+@item @samp{tls}
+Specify that transaction should take place in a TLS channel.
+@end itemize
+
+Here is a simple example:
+@lisp
+ (opensmtpd-option
+ (not #t)
+ (regex #f)
+ (option "for domain")
+ (data (opensmtpd-table
+ (name "domain-table")
+ (data (list "gnu.org" "dismail.de")))))
+@end lisp
+
+The mail must NOT come from the domains @samp{gnu.org} or @samp{dismail.de}.
+
+@item Data Type: opensmtpd-option
+@end itemize
+
+@item Data Type: opensmtpd-local-delivery
+
+This data type represents the configuration of an
+@code{<opensmtpd-local-delivery>} record.
+
+@itemize
+@item
+@code{name} (default: @code{#f})
+
+@code{name} is the string name of the relay action.
+
+@item @code{method} (default: @code{"mbox"})
+
+The email delivery option. Valid options are:
+
+@itemize
+@item @code{"mbox"}
+
+Deliver the message to the user's mbox with mail.local(8).
+
+@item @code{"expand-only"}
+
+Only accept the message if a delivery method was specified in an aliases
+or .forward file.
+
+@item @code{"forward-only"}
+
+Only accept the message if the recipient results in a remote address after
+the processing of aliases or forward file.
+
+@item @code{<opensmtpd-lmtp>}
+
+Deliver the message to an LMTP server at
+@code{<opensmtpd-lmtp>}'s fieldname @code{destination}. The location
+may be expressed as string host:port or as a UNIX socket. Optionally,
+@code{<opensmtpd-lmtponfiguration>}'s fieldname @code{rcpt-to} might be
specified
+to use the recipient email address (after expansion) instead of the local
+user in the LMTP session as RCPT TO@.
+
+@item @code{<opensmtpd-maildir>}
+
+Deliver the message to the maildir in
+@code{<opensmtpd-maildir>}'s fieldname @code{pathname} if specified,
+or by default to @samp{~/Maildir}.
+
+The pathname may contain format specifiers that are expanded before use
+(see the below section about Format Specifiers).
+
+If @code{<opensmtpd-maildir>}'s record fieldname @code{junk} is @code{#t},
+then message will be moved to the ???Junk??? folder if it contains a positive
+???X-Spam??? header. This folder will be created under fieldname
@code{pathname} if
+it does not yet exist.
+
+@item @code{<opensmtpd-mda>}
+
+Delegate the delivery to the @code{<opensmtpd-mda>}'s fieldname
+@code{command} (type string) that receives the message on its standard input.
+
+The @code{command} may contain format specifiers that are expanded before use
+(see Format Specifiers).
+@end itemize
+
+@item @code{alias} (default: @code{#f})
+
+Use the mapping table for aliases expansion. @code{alias} is an
+@code{<opensmtpd-table>}.
+
+@item @code{ttl} (default: @code{#f})
+
+@code{ttl} is a string specify how long a message may remain in the queue.
It's
+format is @samp{n@{s|m|h|d@}}. eg: ``4m'' is four minutes.
+
+@item @code{user} (default: @code{#f} )
+
+@code{user} is the string username for performing the delivery, to be looked up
+with getpwnam(3).
+
+This is used for virtual hosting where a single username is in charge of
+handling delivery for all virtual users.
+
+This option is not usable with the mbox delivery method.
+
+@item @code{userbase} (default: @code{#f})
+
+@code{userbase} is an @code{<opensmtpd-table>} record for mapping user
+lookups instead of the getpwnam(3) function.
+
+The fieldnames @code{user} and @code{userbase} are mutually exclusive.
+
+@item @code{virtual} (default: @code{#f})
+
+@code{virtual} is an @code{<opensmtpd-table>} record is used for virtual
+expansion.
+@end itemize
+
+@item Data Type: opensmtpd-relay
+
+This data type represents the configuration of an
+@code{<opensmtpd-relay>} record.
+
+@itemize
+@item @code{name} (default: @code{#f})
+
+@code{name} is the string name of the relay action.
+
+@item @code{backup} (default: @code{#f})
+
+When @code{#t}, operate as a backup mail exchanger delivering messages to any
+mail exchanger with higher priority.
+
+@item @code{backup-mx} (default: @code{#f})
+
+Operate as a backup mail exchanger delivering messages to any mail exchanger
+with higher priority than mail exchanger identified as string name.
+
+@item @code{helo} (default: @code{#f})
+
+Advertise string heloname as the hostname to other mail exchangers during
+the HELO phase.
+
+@item @code{helo-src} (default: @code{#f} )
+
+ Use the mapping @code{<opensmtpd-table>} to look up a hostname
+matching the source address, to advertise during the HELO phase.
+
+@item @code{domain} (default: @code{#f})
+
+Do not perform MX lookups but look up destination domain in an
+@code{<opensmtpd-table>} and use matching relay url as relay host.
+
+@item @code{host} (default: @code{#f})
+
+Do not perform MX lookups but relay messages to the relay host described by
+the string relay-url. The format for relay-url is
+@samp{[proto://[label@@]]host[:port]}. The following protocols are available:
+
+@multitable {aaaaaaaaaa}
{aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item smtp
+@tab Normal SMTP session with opportunistic STARTTLS (the default).
+@item smtp+tls
+@tab Normal SMTP session with mandatory STARTTLS@.
+@item smtp+notls
+@tab Plain text SMTP session without TLS@.
+@item lmtp
+@tab LMTP session. port is required.
+@item smtps
+@tab SMTP session with forced TLS on connection, default port is
+@item
+@tab 465.
+@end multitable
+
+Unless noted, port defaults to 25.
+
+The label corresponds to an entry in a credentials table, as documented in
+@samp{table(5)}. It is used with the @samp{"smtp+tls"} and @samp{"smtps"}
protocols for
+authentication. Server certificates for those protocols are verified by
+default.
+
+@item @code{pki} (default: @code{#f})
+
+For secure connections, use the certificate associated with
+@code{<opensmtpd-pki>} (declared in a pki directive) to prove the
+client's identity to the remote mail server.
+
+@item @code{srs} (default: @code{#f})
+
+If @code{#t}, then when relaying a mail resulting from a forward, use the
Sender
+Rewriting Scheme to rewrite sender address.
+
+@item @code{tls} (default: @code{#f}) boolean or string ``no-verify''
+
+When @code{#t}, Require TLS to be used when relaying, using mandatory STARTTLS
by
+default. When used with a smarthost, the protocol must not be
+@samp{"smtp+notls://"}. When string @code{"no-verify"}, then do not require a
valid
+certificate.
+
+@item @code{auth} (default: @code{#f}) @code{<opensmtpd-table>}
+
+Use the alist @code{<opensmtpd-table>} for connecting to relay-url
+using credentials. This option is usable only with fieldname @code{host}
option.
+
+@item @code{mail-from} (default: @code{#f}) string
+
+Use the string mailaddress as MAIL FROM address within the SMTP transaction.
+
+@item @code{src} (default: @code{#f}) string | @code{<opensmtpd-table>}
+
+Use the string or @code{<opensmtpd-table>} sourceaddr for the
+source IP address, which is useful on machines with multiple interfaces. If
+the list contains more than one address, all of them are used in such a way
+that traffic is routed as efficiently as possible.
+@end itemize
+
+@item Data Type: opensmtpd-filter
+
+This data type represents the configuration of an
+@code{<opensmtpd-filter>}. This is the filter record one should use
+if they want to use an external package to filter email eg: rspamd or
+spamassassin.
+
+@itemize
+@item @code{name} (default: @code{#f})
+
+The string name of the filter.
+
+@item @code{proc} (default: @code{#f})
+
+The string command or process name. If @code{proc-exec} is @code{#t},
@code{proc} is
+treated as a command to execute. Otherwise, it is a process name.
+
+@item @code{proc-exec} (default: @code{#f})
+@end itemize
+
+@item Data Type: opensmtpd-filter-phase
+
+This data type represents the configuration of an
+@code{<opensmtpd-filter-phase>}.
+
+In a regular workflow, smtpd(8) may accept or reject a message based only on
+the content of envelopes. Its decisions are about the handling of the message,
+not about the handling of an active session.
+
+Filtering extends the decision making process by allowing smtpd(8) to stop at
+each phase of an SMTP session, check that options are met, then decide if a
+session is allowed to move forward.
+
+With filtering via an @code{<opensmtpd-filter-phase>} record, a
+session may be interrupted at any phase before an envelope is complete. A
+message may also be rejected after being submitted, regardless of whether the
+envelope was accepted or not.
+
+@itemize
+@item @code{name} (default: @code{#f})
+
+The string name of the filter phase.
+
+@item @code{phase-name} (default: @code{#f})
+
+The string name of the phase. Valid values are:
+
+@multitable {aaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item ``connect''
+@tab upon connection, before a banner is displayed
+@item ``helo''
+@tab after HELO command is submitted
+@item ``ehlo''
+@tab after EHLO command is submitted
+@item ``mail-from''
+@tab after MAIL FROM command is submitted
+@item ``rcpt-to''
+@tab after RCPT TO command is submitted
+@item ``data''
+@tab after DATA command is submitted
+@item ``commit''
+@tab after message is fully is submitted
+@end multitable
+
+@item @code{options} (default @code{#f})
+
+A list of unique @code{<opensmtpd-option>} records.
+
+At each phase, various options, specified by a list of
+@code{<opensmtpd-option>}, may be checked. The
+@code{<opensmtpd-option>}'s fieldname 'option' values of: ``fcrdns'',
+``rdns'', and ``src'' data are available in all phases, but other data must
have
+been already submitted before they are available. Options with a @samp{<table>}
+next to them require the @code{<opensmtpd-option>}'s fieldname
+@code{data} to be an @code{<opensmtpd-table>}. There are the available
+options:
+
+@multitable {aaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item fcrdns
+@tab forward-confirmed reverse DNS is valid
+@item rdns
+@tab session has a reverse DNS
+@item rdns <table>
+@tab session has a reverse DNS in table
+@item src <table>
+@tab source address is in table
+@item helo <table>
+@tab helo name is in table
+@item auth
+@tab session is authenticated
+@item auth <table>
+@tab session username is in table
+@item mail-from <table>
+@tab sender address is in table
+@item rcpt-to <table>
+@tab recipient address is in table
+@end multitable
+
+These conditions may all be negated by setting
+@code{<opensmtpd-option>}'s fieldname @code{not} to @code{#t}.
+
+Any conditions that require a table may indicate that tables include regexs
+setting @code{<opensmtpd-option>}'s fieldname @code{regex} to @code{#t}.
+
+@item @code{decision}
+
+A string decision to be taken. Some decisions require an @code{message} or
+@code{value}. Valid strings are:
+
+@multitable {aaaaaaaaaaaaaaaaaaaa}
{aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item ``bypass''
+@tab the session or transaction bypasses filters
+@item ``disconnect'' message
+@tab the session is disconnected with message
+@item ``junk''
+@tab the session or transaction is junked, i.e., an
+@item
+@tab ???X-Spam: yes??? header is added to any messages
+@item ``reject'' message
+@tab the command is rejected with message
+@item ``rewrite'' value
+@tab the command parameter is rewritten with value
+@end multitable
+
+Decisions that involve a message require that the message be RFC valid,
+meaning that they should either start with a 4xx or 5xx status code.
+Descisions can be taken at any phase, though junking can only happen before
+a message is committed.
+
+@item @code{message} (default @code{#f})
+
+A string message beginning with a 4xx or 5xx status code.
+
+@item @code{value} (default: @code{#f})
+
+A number value. @code{value} and @code{message} are mutually exclusive.
+@end itemize
+
+@item Data Type: opensmtpd-option
+
+This data type represents the configuration of an
+@code{<opensmtpd-option>}, which is used by
+@code{<opensmtpd-filter-phase>} and @code{<opensmtpd-match>}
+to match various options for email.
+
+@itemize
+@item @code{conditition} (default @code{#f})
+
+A string option to be taken. Some options require a string or an
+@code{<opensmtpd-table>} via the fieldname data. When the option
+record is used inside of an @code{<opensmtpd-filter-phase>}, then
+valid strings are:
+
+At each phase, various options may be matched. The fcrdns, rdns, and src
+data are available in all phases, but other data must have been already
+submitted before they are available.
+
+@multitable {aaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item ``fcrdns''
+@tab forward-confirmed reverse DNS is valid
+@item ``rdns''
+@tab session has a reverse DNS
+@item ``rdns'' <table>
+@tab session has a reverse DNS in table
+@item ``src'' <table>
+@tab source address is in table
+@item ``helo'' <table>
+@tab helo name is in table
+@item ``auth''
+@tab session is authenticated
+@item ``auth'' <table>
+@tab session username is in table
+@item ``mail-from'' <table>
+@tab sender address is in table
+@item ``rcpt-to'' <table>
+@tab recipient address is in table
+@end multitable
+
+When @code{<opensmtpd-option>} is used inside of an
+@code{<opensmtpd-match>}, then valid strigs for fieldname @code{option}
+are: ``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'', or
``tls''.
+
+@item @code{data} (default @code{#f}) @code{<opensmtpd-table>}
+
+Some options require a table to be present. One would specify that table
+here.
+@item @code{regex} (default: @code{#f}) boolean
+
+Any options using a table may indicate that tables hold regex by
+prefixing the table name with the keyword regex.
+
+@item @code{not} (default: @code{#f}) boolean
+
+When @code{#t}, this option record is negated.
+@end itemize
+
+@item Data Type: opensmtpd-table
+
+This data type represents the configuration of an
+@code{<opensmtpd-table>}.
+
+@itemize
+@item @code{name} (default @code{#f})
+
+@code{name} is the name of the @code{<opensmtpd-table>} record.
+
+@item @code{data} (default: @code{#f})
+
+@code{data} expects a list of strings or an alist, which is a list of
+cons cells. eg: @code{(data (list ("james" . "password")))} OR
+@code{(data (list ("gnu.org" "fsf.org")))}.
+@end itemize
+
+@item Data Type: opensmtpd-pki
+
+This data type represents the configuration of an
+@code{<opensmtpd-pki>}.
+
+@itemize
+@item @code{domain} (default @code{#f})
+
+@code{domain} is the string name of the @code{<opensmtpd-pki>} record.
+
+@item @code{cert} (default: @code{#f})
+
+@code{cert} (default: @code{#f})
+
+@code{cert} is the string certificate filename to use for this pki.
+
+@item @code{key} (default: @code{#f})
+
+@code{key} is the string certificate falename to use for this pki.
+
+@item @code{dhe} (default: @code{"none"})
+
+Specify the DHE string parameter to use for DHE cipher suites with host
+pkiname. Valid parameter values are ``none'', ``legacy'', or ``auto''. For
``legacy'', a
+fixed key length of 1024 bits is used, whereas for ``auto'', the key length is
+determined automatically. The default is ``none'', which disables DHE cipher
+suites.
+@end itemize
+
+@item Data Type: opensmtpd-maildir
+
+@itemize
+@item @code{pathname} (default: @code{"~/Maildir"})
+
+Deliver the message to the maildir if pathname if specified, or by default
+to @samp{~/Maildir}.
+
+The pathname may contain format specifiers that are expanded before use
+(see FORMAT SPECIFIERS).
+
+@item @code{junk} (default: @code{#f})
+
+If the junk argument is @code{#t}, then the message will be moved to the
@samp{???Junk???}
+folder if it contains a positive @samp{???X-Spam???} header. This folder will
be
+created under pathname if it does not yet exist.
+@end itemize
+
+@item Data Type: opensmtpd-mda
+
+@itemize
+@item @code{name}
+
+The string name for this MDA command.
+
+@item @code{command}
+
+Delegate the delivery to a command that receives the message on its standard
+input.
+
+The command may contain format specifiers that are expanded before use (see
+FORMAT SPECIFIERS).
+@end itemize
+
+@item Data Type: opensmtpd-queue
+
+@itemize
+@item @code{compression} (default @code{#f})
+
+Store queue files in a compressed format. This may be useful to save disk
+space.
+
+@item @code{encryption} (default @code{#f})
+
+Encrypt queue files with EVP@math{_aes}@math{_256}@math{_gcm}(3). If no key is
specified, it is
+read with getpass(3). If the string stdin or a single dash (???-???) is given
+instead of a key, the key is read from the standard input.
+
+@item @code{ttl-delay} (default @code{#f})
+
+Set the default expiration time for temporarily undeliverable messages,
+given as a positive decimal integer followed by a unit s, m, h, or d. The
+default is four days (``4d'').
+@end itemize
+
+@item Data Type: opensmtpd-smtp
+
+Data type representing an @code{<opensmtpd-smtp>} record.
+
+@itemize
+@item @code{ciphers} (default: @code{#f})
+
+Set the control string for
SSL@math{_CTX}@math{_set}@math{_cipher}@math{_list}(3). The default is
+ ``HIGH:!aNULL:!MD5''.
+
+@item @code{limit-max-mails} (default: @code{100})
+
+Limit the number of messages to count for each sessio
+
+@item @code{limit-max-rcpt} (default: @code{1000})
+
+Limit the number of recipients to count for each transaction.
+
+@item @code{max-message-size} (default: @code{35M})
+
+Reject messages larger than size, given as a positive number of bytes or as
+a string to be parsed with scan@math{_scaled}(3).
+
+@item @code{sub-addr-delim character} (default: @code{+})
+
+When resolving the local part of a local email address, ignore the ASCII
+character and all characters following it. This is helpful for email
+filters. @samp{"admin+bills@@gnu.org"} is the same email address as
+@samp{"admin@@gnu.org"}. BUT an email filter can filter emails addressed to
first
+email address into a 'Bills' email folder.
+@end itemize
+
+@item Data Type: opensmtpd-srs
+
+@itemize
+@item @code{key} (default: @code{#f})
+
+Set the secret key to use for SRS, the Sender Rewriting Scheme.
+
+@item @code{backup-key} (default: @code{#f})
+
+Set a backup secret key to use as a fallback for SRS@. This can be used to
+implement SRS key rotation.
+
+@item @code{ttl-delay} (default: @code{"4d"})
+
+Set the time-to-live delay for SRS envelopes. After this delay, a bounce
+reply to the SRS address will be discarded to limit risks of forged
+addresses.
+@end itemize
+
+@item Format Specifiers
+
+Some configuration records support expansion of their parameters at
+runtime. Such records (for example
+@code{<opensmtpd-maildir>}, @code{<opensmtpd-mda>}) may use
+format specifiers which are expanded before delivery or relaying. The
+following formats are currently supported:
+
+@multitable {aaaaaaaaaaaaaaaaaaa}
{aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item @samp{%@{sender@}}
+@tab sender email address, may be empty string
+@item @samp{%@{sender.user@}}
+@tab user part of the sender email address, may be empty
+@item @samp{%@{sender.domain@}}
+@tab domain part of the sender email address, may be empty
+@item @samp{%@{rcpt@}}
+@tab recipient email address
+@item @samp{%@{rcpt.user@}}
+@tab user part of the recipient email address
+@item @samp{%@{rcpt.domain@}}
+@tab domain part of the recipient email address
+@item @samp{%@{dest@}}
+@tab recipient email address after expansion
+@item @samp{%@{dest.user@}}
+@tab user part after expansion
+@item @samp{%@{dest.domain@}}
+@tab domain part after expansion
+@item @samp{%@{user.username@}}
+@tab local user
+@item @samp{%@{user.directory@}}
+@tab home directory of the local user
+@item @samp{%@{mbox.from@}}
+@tab name used in mbox From separator lines
+@item @samp{%@{mda@}}
+@tab mda command, only available for mda wrappers
+@end multitable
+
+Expansion formats also support partial expansion using the optional bracket
notations
+with substring offset. For example, with recipient domain
@samp{???example.org???}:
+
+@multitable {aaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaa}
+@item @samp{%@{rcpt.domain[0]@}}
+@tab expands to ???e???
+@item @samp{%@{rcpt.domain[1]@}}
+@tab expands to ???x???
+@item @samp{%@{rcpt.domain[8:]@}}
+@tab expands to ???org???
+@item @samp{%@{rcpt.domain[-3:]@}}
+@tab expands to ???org???
+@item @samp{%@{rcpt.domain[0:6]@}}
+@tab expands to ???example???
+@item @samp{%@{rcpt.domain[0:-4]@}}
+@tab expands to ???example???
+@end multitable
+
+In addition, modifiers may be applied to the token. For example, with
recipient
+@samp{???User+Tag@@Example.org???}:
+
+@multitable {aaaaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item @samp{%@{rcpt:lowercase@}}
+@tab expands to ???user+tag@@example.org???
+@item @samp{%@{rcpt:uppercase@}}
+@tab expands to ???USER+TAG@@EXAMPLE.ORG???
+@item @samp{%@{rcpt:strip@}}
+@tab expands to ???User@@Example.org???
+@item @samp{%@{rcpt:lowercasestrip@}}
+@tab expands to ???user@@example.org???
+@end multitable
+
+For security concerns, expanded values are sanitized and potentially dangerous
+characters are replaced with ???:???. In situations where they are desirable,
the
+???raw??? modifier may be applied. For example, with recipient
+@samp{???user+t?g@@example.org???}:
+
+@multitable {aaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item @samp{%@{rcpt@}}
+@tab expands to ???user+t:g@@example.org???
+@item @samp{%@{rcpt:raw@}}
+@tab expands to ???user+t?g@@example.org???
+@end multitable
+@end itemize
+
@subsubheading Exim Service
@cindex mail transfer agent (MTA)
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index 43f144a42d..d86e083d19 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -58,10 +58,146 @@ (define-module (gnu services mail)
mailbox-configuration
namespace-configuration
+ opensmtpd-table
+ opensmtpd-table?
+ opensmtpd-table-name
+ opensmtpd-table-file-db
+ opensmtpd-table-data
+
+ opensmtpd-ca
+ opensmtpd-ca?
+ opensmtpd-ca-name
+ opensmtpd-ca-file
+
+ opensmtpd-pki
+ opensmtpd-pki?
+ opensmtpd-pki-domain
+ opensmtpd-pki-cert
+ opensmtpd-pki-key
+ opensmtpd-pki-dhe
+
+ opensmtpd-local-delivery
+ opensmtpd-local-delivery?
+ opensmtpd-local-delivery-method
+ opensmtpd-local-delivery-alias
+ opensmtpd-local-delivery-ttl
+ opensmtpd-local-delivery-user
+ opensmtpd-local-delivery-userbase
+ opensmtpd-local-delivery-virtual
+ opensmtpd-local-delivery-wrapper
+
+ opensmtpd-maildir
+ opensmtpd-maildir?
+ opensmtpd-maildir-pathname
+ opensmtpd-maildir-junk
+
+ opensmtpd-mda
+ opensmtpd-mda-name
+ opensmtpd-mda-command
+
+ opensmtpd-lmtp
+ opensmtpd-lmtp-destination
+ opensmtpd-lmtp-rcpt
+
+ opensmtpd-relay
+ opensmtpd-relay?
+ opensmtpd-relay-backup
+ opensmtpd-relay-backup-mx
+ opensmtpd-relay-helo
+ opensmtpd-relay-domain
+ opensmtpd-relay-host
+ opensmtpd-relay-pki
+ opensmtpd-relay-srs
+ opensmtpd-relay-tls
+ opensmtpd-relay-auth
+ opensmtpd-relay-mail-from
+ opensmtpd-relay-src
+
+ opensmtpd-option
+ opensmtpd-option?
+ opensmtpd-option-option
+ opensmtpd-option-not
+ opensmtpd-option-regex
+ opensmtpd-option-data
+
+ opensmtpd-filter-phase
+ opensmtpd-filter-phase?
+ opensmtpd-filter-phase-name
+ opensmtpd-filter-phase-phase-name
+ opensmtpd-filter-phase-options
+ opensmtpd-filter-phase-decision
+ opensmtpd-filter-phase-message
+ opensmtpd-filter-phase-value
+
+ opensmtpd-filter
+ opensmtpd-filter?
+ opensmtpd-filter-name
+ opensmtpd-filter-proc
+
+ opensmtpd-interface
+ opensmtpd-interface?
+ opensmtpd-interface-interface
+ opensmtpd-interface-family
+ opensmtpd-interface-auth
+ opensmtpd-interface-auth-optional
+ opensmtpd-interface-filters
+ opensmtpd-interface-hostname
+ opensmtpd-interface-hostnames
+ opensmtpd-interface-mask-src
+ opensmtpd-interface-disable-dsn
+ opensmtpd-interface-pki
+ opensmtpd-interface-port
+ opensmtpd-interface-proxy-v2
+ opensmtpd-interface-received-auth
+ opensmtpd-interface-senders
+ opensmtpd-interface-secure-connection
+ opensmtpd-interface-tag
+
+ opensmtpd-socket
+ opensmtpd-socket?
+ opensmtpd-socket-filters
+ opensmtpd-socket-mask-src
+ opensmtpd-socket-tag
+
+ opensmtpd-match
+ opensmtpd-match?
+ opensmtpd-match-action
+ opensmtpd-match-options
+
+ opensmtpd-smtp
+ opensmtpd-smtp?
+ opensmtpd-smtp-ciphers
+ opensmtpd-smtp-limit-max-mails
+ opensmtpd-smtp-limit-max-rcpt
+ opensmtpd-smtp-max-message-size
+ opensmtpd-smtp-sub-addr-delim character
+
+ opensmtpd-srs
+ opensmtpd-srs?
+ opensmtpd-srs-key
+ opensmtpd-srs-backup-key
+ opensmtpd-srs-ttl-delay
+
+ opensmtpd-queue
+ opensmtpd-queue?
+ opensmtpd-queue-compression
+ opensmtpd-queue-encryption
+ opensmtpd-queue-ttl-delay
+
opensmtpd-configuration
opensmtpd-configuration?
- opensmtpd-service-type
- %default-opensmtpd-config-file
+ 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
mail-aliases-service-type
@@ -1641,22 +1777,1942 @@ (define (generate-dovecot-documentation)
(listeners unix-listener-configuration fifo-listener-configuration
inet-listener-configuration))
(protocol-configuration ,protocol-configuration-fields))
- 'dovecot-configuration))
+ 'dovecot-configuration))
;;;
;;; OpenSMTPD.
;;;
+;; file-exists? is in the guile standard library. BUT I errors if its arg
+;; is a list. eg: (file-exists? (list "hello" "hello"))
+;; TODO I need to find a way to remove this definition and rewrite my code.
+(define (file-exists? file)
+ (if (string? file)
+ (access? file F_OK)
+ #f))
+
+;; some fieldnames have a default value of #f, which is ok. They cannot have
a value of #t.
+;; for example opensmtpd-table-data can be #f, BUT NOT true.
+;; my/sanitize procedure tests values to see if they are of the right kind.
+;; procedure false? is needed to allow fields like 'values' to be blank,
(empty), or #f BUT also
+;; have a value like a list of strings.
+(define (false? var)
+ (eq? #f var))
+
+;; this procedure takes in a var and a list of procedures. It loops through
list of procedures passing in var to each.
+;; if one procedure returns #t, the function returns true. Otherwise #f.
+;; TODO for fun rewrite this using map
+;; If I rewrote it in map, then it may help with sanitizing.
+;; eg: I could then potentially easily sanitize vars with lambda procedures.
+(define (is-value-right-type? var list-of-procedures record fieldname)
+ (if (null? list-of-procedures)
+ #f
+ (if ((car list-of-procedures) var)
+ #t
+ (is-value-right-type? var (cdr list-of-procedures) record
fieldname))))
+
+;; converts strings like this:
+;; "apple, ham, cherry" -> "apple, ham, or cherry"
+;; "pineapple" -> "pinneapple".
+;; "cheese, grapefruit, or jam" -> "cheese, grapefruit, or jam"
+(define (add-comma-or string)
+ (define last-comma-location (string-rindex string #\,))
+ (if last-comma-location
+ (if (string-contains string ", or" last-comma-location)
+ string
+ (string-replace string ", or" last-comma-location
+ (+ 1 last-comma-location)))
+ string))
+
+(define (list-of-procedures->string procedures)
+ (define string
+ (let loop ((procedures procedures))
+ (if (null? procedures)
+ ""
+ (begin
+ (string-append
+ (cond ((eq? false? (car procedures))
+ "#f , ")
+ ((eq? boolean? (car procedures))
+ "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? (car procedures))
+ "an <opensmtpd-pki> record, ")
+ ((eq? opensmtpd-table? (car procedures))
+ "an <opensmtpd-table> record, ")
+ ((eq? list-of-unique-opensmtpd-match? (car procedures))
+ "a list of unique <opensmtpd-match> records, ")
+ ((eq? list-of-strings-or-gexps? (car procedures))
+ "a list of strings or gexps, ")
+ ((eq? table-whose-data-are-assoc-list? (car procedures))
+ (string-append
+ "an <opensmtpd-table> record whose fieldname 'data' are
an assoc-list \n"
+ "(eg: (opensmtpd-table (name \"hostnames\") (data
'((\"124.394.23.1\" . \"gnu.org\"))))), "))
+ ((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")))
+
+(define (string-in-list? string list)
+ (member string list))
+
+(define (list-of-strings-or-gexps? list)
+ (and (list? list)
+ (cond ((null? list)
+ #t)
+ ((or (string? (car list))
+ (gexp? (car list))
+ (local-file? (car list))
+ (file-append? (car list))
+ (plain-file? (car list))
+ (computed-file? (car list))
+ (program-file? (car list)))
+ (list-of-strings-or-gexps? (cdr list)))
+ (else #f))))
+
+(define (my/sanitize var record fieldname list-of-procedures)
+ (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-tables:
+;;
+;; (opensmtpd-table (name "root accounts") (data '(("joshua" .
"root@dismail.de") ("joshua" . "postmaster@dismail.de"))))
+;; (opensmtpd-table (name "root accounts") (data (list "mysite.me"
"your-site.com")))
+;; TODO should <opensmtpd-table> support have a fieldname 'file'?
+;; Or should I change name to name-or-file ?
+(define-record-type* <opensmtpd-table>
+ opensmtpd-table make-opensmtpd-table
+ opensmtpd-table?
+ this-record
+ (name opensmtpd-table-name ;; string
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-table" "name" (list
string?)))))
+ (file-db opensmtpd-table-file-db
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-table" "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-data
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-table" "values"
+ (list list-of-strings? assoc-list?
file-exists?)))))
+ ;; 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-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-type
+ (default #f)
+ (thunked)
+ (sanitize (lambda (var)
+ (cond ((opensmtpd-table-data this-record)
+ (if (list-of-strings? (opensmtpd-table-data
this-record))
+ (quote list-of-strings)
+ (quote assoc-list)))
+ ((file-exists? (opensmtpd-table-data this-record))
+ (if (opensmtpd-table-file-db this-record)
+ (quote db)
+ (quote file)))
+ (else
+ (display "opensmtpd-table-type is broke\n")
+ (throw 'bad! var)))))))
+
+(define-record-type* <opensmtpd-ca>
+ opensmtpd-ca make-opensmtpd-ca
+ opensmtpd-ca?
+ (name opensmtpd-ca-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-ca" "name" (list string?)))))
+ (file opensmtpd-ca-file
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-ca" "file" (list
file-exists?))))))
+
+(define-record-type* <opensmtpd-pki>
+ opensmtpd-pki make-opensmtpd-pki
+ opensmtpd-pki?
+ (domain opensmtpd-pki-domain
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-pki" "domain" (list
string?)))))
+ ;; TODO/FIXME this should probably be a list of files. The opensmtpd
documentation says
+ ;; that you could have a list of files:
+ ;;
+ ;; pki pkiname cert certfile
+ ;; Associate certificate file certfile with host pkiname, and use that file
to prove
+ ;; the identity of the mail server to clients. pkiname is the server's
name, 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-cert
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-pki" "cert" (list
file-exists?)))))
+ (key opensmtpd-pki-key
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-pki" "key" (list
file-exists?)))))
+ ; todo sanitize this. valid parameters are "none", "legacy", or "auto".
+ (dhe opensmtpd-pki-dhe
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-dhe" "dhe" (list false?
string?))))))
+
+(define-record-type* <opensmtpd-lmtp>
+ opensmtpd-lmtp make-opensmtpd-lmtp
+ opensmtpd-lmtp?
+ (destination opensmtpd-lmtp-destination
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-lmtp" "destination"
+ (list string?)))))
+ (rcpt-to opensmtpd-lmtp-rcpt-to
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-lmtp" "rcpt-to"
+ (list false? string?))))))
+
+(define-record-type* <opensmtpd-mda>
+ opensmtpd-mda make-opensmtpd-mda
+ opensmtpd-mda?
+ (name opensmtpd-mda-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-mda" "name"
+ (list string?)))))
+ ;; TODO should I allow this command to be a gexp?
+ (command opensmtpd-mda-command
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-mda" "command"
+ (list string?))))))
+
+(define-record-type* <opensmtpd-maildir>
+ opensmtpd-maildir make-opensmtpd-maildir
+ opensmtpd-maildir?
+ (pathname opensmtpd-maildir-pathname
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-maildir" "pathname"
+ (list false? string?)))))
+ (junk opensmtpd-maildir-junk
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-maildir" "junk"
+ (list boolean?))))))
+
+(define-record-type* <opensmtpd-local-delivery>
+ opensmtpd-local-delivery make-opensmtpd-local-delivery
+ opensmtpd-local-delivery?
+ (name opensmtpd-local-delivery-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-local-delivery" "name"
+ (list string?)))))
+ (method opensmtpd-local-delivery-method
+ (default "mbox")
+ (sanitize (lambda (var)
+ (cond
+ ((or (opensmtpd-lmtp? var)
+ (opensmtpd-maildir? var)
+ (opensmtpd-mda? var)
+ (string=? var "mbox")
+ (string=? var "expand-only")
+ (string=? var "forward-only"))
+ var)
+ (else
+ (begin
+ (display (string-append "<opensmtpd-local-delivery>
fieldname 'method' must be of type \n"
+ "\"mbox\", \"expand-only\",
\"forward-only\" \n"
+ "<opensmtpd-lmtp>,
<opensmtpd-maildir>, \n"
+ "or <opensmtpd-mda>.\n"))
+ (throw 'bad! var)))))))
+ (alias opensmtpd-local-delivery-alias
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-local-delivery" "alias"
+ (list false? opensmtpd-table?)))))
+ (ttl opensmtpd-local-delivery-ttl
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-local-delivery" "ttl"
+ (list false? string?)))))
+ (user opensmtpd-local-delivery-user
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-local-delivery" "user"
+ (list false? string?)))))
+ (userbase opensmtpd-local-delivery-userbase
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-local-delivery" "userbase"
+ (list false? opensmtpd-table?)))))
+ (virtual opensmtpd-local-delivery-virtual
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-local-delivery" "virtual"
+ (list false? opensmtpd-table?)))))
+ (wrapper opensmtpd-local-delivery-wrapper
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-local-delivery" "wrapper"
+ (list false? string?))))))
+
+;; FIXME/TODO this is a valid opensmtpd-relay record
+;; (opensmtpd-relay
+;; (pki (opensmtpd-pki
+;; (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-relay>
+ opensmtpd-relay make-opensmtpd-relay
+ opensmtpd-relay?
+ (name opensmtpd-relay-name
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "name"
+ (list string?))))
+ (default #f))
+ (backup opensmtpd-relay-backup ;; boolean
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "backup"
+ (list boolean?)))))
+ (backup-mx opensmtpd-relay-backup-mx ;; string mx name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "backup-mx"
+ (list false? string?)))))
+ (helo opensmtpd-relay-helo
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "helo"
+ (list false? string? opensmtpd-table?))))
+ (default #f))
+ (helo-src opensmtpd-relay-helo-src
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "helo-src"
+ (list false? string? opensmtpd-table?))))
+ (default #f))
+ (domain opensmtpd-relay-domain
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "domain"
+ (list false? opensmtpd-table?))))
+ (default #f))
+ (host opensmtpd-relay-host
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "host"
+ (list false? string?))))
+ (default #f))
+ (pki opensmtpd-relay-pki
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "pki"
+ (list false? opensmtpd-pki?)))))
+ (srs opensmtpd-relay-srs
+ (default #f)
+ (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "srs"
+ (list boolean?))))
+ (tls opensmtpd-relay-tls
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "tls"
+ (list false? string?)))))
+ (auth opensmtpd-relay-auth
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "auth"
+ (list false? opensmtpd-table?))))
+ (default #f))
+ (mail-from opensmtpd-relay-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-relay-src
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-relay" "src"
+ (list false? string? opensmtpd-table?))))
+ (default #f)))
+
+;; this record is used by <opensmtpd-filter-phase> &
+;; <opensmtpd-match>
+(define-record-type* <opensmtpd-option>
+ opensmtpd-option make-opensmtpd-option
+ opensmtpd-option?
+ (option opensmtpd-option-option
+ (default #f)
+ (sanitize (lambda (var)
+ (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>
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-not
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-option" "not"
+ (list boolean?)))))
+ (regex opensmtpd-option-regex
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-option" "regex"
+ (list boolean?)))))
+ (data opensmtpd-option-data
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-option" "data"
+ (list false? string? opensmtpd-table?))))))
+
+(define-record-type* <opensmtpd-filter-phase>
+ opensmtpd-filter-phase make-opensmtpd-filter-phase
+ opensmtpd-filter-phase?
+ (name opensmtpd-filter-phase-name ;; string chain-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter-phase" "name"
+ (list string?)))))
+ (phase opensmtpd-filter-phase-phase ;; string
+ (default #f)
+ (sanitize (lambda (var)
+ (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> 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-options
+ (default #f)
+ (sanitize (lambda (var)
+ ;; returns #t if list is a unique list of
<opensmtpd-option>
+ (define (list-of-opensmtpd-option? list)
+ (and (list-of-type? list opensmtpd-option?)
+ (not (contains-duplicate? list))))
+
+ (define (list-has-duplicates-or-non-opensmtpd-option
list)
+ (not (list-of-opensmtpd-option? list)))
+
+ ;; input <opensmtpd-option>
+ ;; return #t if <opensmtpd-option> fieldname 'option'
+ ;; that needs a corresponding table has one. Otherwise
#f
+ (define (opensmtpd-option-has-table? record)
+ (define decision (opensmtpd-option-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? (opensmtpd-option-data
record))
+ #t)))
+
+ (define (list-of-opensmtpd-option-has-table? list)
+ (list-of-type? list opensmtpd-option-has-table?))
+
+ (define (some-opensmtpd-option-in-list-lack-table? list)
+ (not (list-of-opensmtpd-option-has-table? list)))
+
+ (sanitize-options-for-filter-phase-configuration var)
+ )))
+ (decision opensmtpd-filter-phase-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-message
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter-phase" "message"
+ (list false? string?)))))
+ (value opensmtpd-filter-phase-value
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter-phase" "value"
+ (list false? number?))))))
+
+(define-record-type* <opensmtpd-filter>
+ opensmtpd-filter make-opensmtpd-filter
+ opensmtpd-filter?
+ (name opensmtpd-filter-name
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter" "name"
+ (list string?)))))
+ (exec opensmtpd-filter-exec
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-filter" "exec"
+ (list boolean?)))))
+ (proc opensmtpd-filter-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?
list-of-strings-or-gexps?))))))
+
+;; There is another type of filter that opensmtpd supports, which is a filter
chain.
+;; A filter chain is a list of <opensmtpd-filter-phase> and <opensmtpd-filter>.
+;; 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> or
<opensmtpd-filter-phase>
+;; returns # otherwise
+(define (opensmtpd-filter-chain? %filters)
+ (and (list-of-unique-filter-or-filter-phase? %filters)
+ (< 1 (length %filters))))
+
+(define-record-type* <opensmtpd-interface>
+ opensmtpd-interface make-opensmtpd-interface
+ opensmtpd-interface?
+ ;; interface may be an IP address, interface group, or domain name
+ (interface opensmtpd-interface-interface
+ (default "lo"))
+ (family opensmtpd-interface-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-interface> fieldname 'family'
must be string \"inet4\" or \"inet6\".\n")
+ (throw 'bad! var)))))))
+ (auth opensmtpd-interface-auth
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "auth"
+ (list boolean?
table-whose-data-are-assoc-list?)))))
+ (auth-optional opensmtpd-interface-auth-optional
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface"
"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-interface-filters
+ (default #f)
+ (sanitize (lambda (var)
+ (sanitize-filter-phases var))))
+ (hostname opensmtpd-interface-hostname
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "hostname"
+ (list false? string?)))))
+ (hostnames opensmtpd-interface-hostnames
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "hostnames"
+ (list false?
table-whose-data-are-assoc-list?)))))
+ (mask-src opensmtpd-interface-mask-src
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "mask-src"
+ (list boolean?)))))
+ (disable-dsn opensmtpd-interface-disable-dsn
+ (default #f))
+ (pki opensmtpd-interface-pki
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "pki"
+ (list false? opensmtpd-pki?)))))
+ (port opensmtpd-interface-port
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "port"
+ (list false? integer?)))))
+ (proxy-v2 opensmtpd-interface-proxy-k2
+ (default #f))
+ (received-auth opensmtpd-interface-received-auth
+ (default #f))
+ ;; TODO add in a senders option!
+ ;; string or <opensmtpd-senders> record
+ ;; (senders opensmtpd-interface-senders
+ ;; (sanitize (lambda (var)
+ ;; (my/sanitize var "opensmtpd-interface" "port" (list
false? integer?))))
+ ;; (default #f))
+ (secure-connection opensmtpd-interface-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-interface-tag
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "tag"
+ (list false? string?))))
+ (default #f)))
+
+(define-record-type* <opensmtpd-socket-configuration>
+ opensmtpd-socket-configuration make-opensmtpd-socket-configuration
+ opensmtpd-socket-configuration?
+ ;; false or <opensmtpd-filter> or list of <opensmtpd-filter>
+ (filters opensmtpd-socket-configuration-filters
+ (sanitize (lambda (var)
+ (sanitize-filter-phases var)))
+ (default #f))
+ (mask-src opensmtpd-socket-configuration-mask-src
+ (default #f))
+ (tag opensmtpd-socket-configuration-tag
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-interface" "tag"
+ (list false? string?))))
+ (default #f)))
+
+
+(define-record-type* <opensmtpd-match>
+ opensmtpd-match make-opensmtpd-match
+ opensmtpd-match?
+ ;;TODO? Perhaps I should add in a reject fieldname. If reject
+ ;;is #t, then the match record will be a reject match record.
+ ;; (opensmtpd-match (reject #t)) vs. (opensmtpd-match (action 'reject))
+ ;; To do this, I will also have to 'reject' mutually exclusive. AND an
match with 'reject' can have no action defined.
+ (action opensmtpd-match-action
+ (default #f)
+ (sanitize (lambda (var)
+ (if (or (opensmtpd-relay? var)
+ (opensmtpd-local-delivery? var)
+ (eq? (quote reject) var))
+ var
+ (begin
+ (display
+ (string-append "<opensmtpd-match> fieldname
'action' is of type <opensmtpd-relay>, \n"
+ "<opensmtpd-local-delivery>, 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-options
+ (default #f)
+ (sanitize (lambda (var)
+ (cond ((not var)
+ #f)
+ ((not (list-of-unique-opensmtpd-option? var))
+ (throw-error var '("<opensmtpd-match> fieldname
'options' is a list of unique \n"
+ "<opensmtpd-option> records.
\n")))
+ (else
(sanitize-list-of-options-for-match-configuration var)))))))
+
+(define-record-type* <opensmtpd-smtp>
+ opensmtpd-smtp make-opensmtpd-smtp
+ opensmtpd-smtp?
+ (ciphers opensmtpd-smtp-ciphers
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp" "ciphers"
+ (list false? string?)))))
+ (limit-max-mails opensmtpd-smtp-limit-max-mails
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp"
"limit-max-mails"
+ (list false? integer?)))))
+ (limit-max-rcpt opensmtpd-smtp-limit-max-rcpt
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp"
"limit-max-rcpt"
+ (list false? integer?)))))
+ (max-message-size opensmtpd-smtp-max-message-size
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp"
"max-message-size"
+ (list false? integer? string?)))))
+ ;; FIXME/TODO the sanitize function of sub-addr-delim should accept a string
of length one not string?
+ (sub-addr-delim opensmtpd-smtp-sub-addr-delim
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-smtp"
"sub-addr-delim"
+ (list false? integer? string?))))))
+
+(define-record-type* <opensmtpd-srs>
+ opensmtpd-srs make-opensmtpd-srs
+ opensmtpd-srs?
+ ;; TODO should this be a file?
+ (key opensmtpd-srs-key
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-srs" "key"
+ (list false? boolean? string?)))))
+ ;; TODO should this also be a file?
+ (backup-key opensmtpd-srs-backup-key
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-srs" "backup-key"
+ (list false? integer?)))))
+ (ttl-delay opensmtpd-srs-ttl-delay
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-srs" "ttl-delay"
+ (list false? string?))))))
+
+(define-record-type* <opensmtpd-queue>
+ opensmtpd-queue make-opensmtpd-queue
+ opensmtpd-queue?
+ (compression opensmtpd-queue-compression
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-queue" "compression"
+ (list boolean?)))))
+ (encryption opensmtpd-queue-encryption
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-queue" "encryption"
+ (list boolean? string? file-exists?)))))
+ (ttl-delay opensmtpd-queue-ttl-delay
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-queue" "ttl-delay"
+ (list false? string?))))))
+
(define-record-type* <opensmtpd-configuration>
opensmtpd-configuration make-opensmtpd-configuration
opensmtpd-configuration?
- (package opensmtpd-configuration-package
- (default opensmtpd))
+ (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?)))))
+ ;; list of many records of type opensmtpd-interface
+ (listen-ons opensmtpd-configuration-listen-ons
+ (default (list (opensmtpd-interface)))
+ (sanitize (lambda (var)
+ (if (list-of-opensmtpd-interface? var)
+ var
+ (begin
+ (display "<opensmtpd-configuration> fieldname
'listen-ons' expects a list of records ")
+ (display "of one or more unique
<opensmtpd-interface> records.\n")
+ (throw 'bad! var))))))
+ ;; accepts type <opensmtpd-socket-configuration>
+ (listen-on-socket opensmtpd-configuration-listen-on-socket
+ (default (opensmtpd-socket-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? gexp?)))))
+ (matches opensmtpd-configuration-matches
+ (default (list (opensmtpd-match
+ (action (opensmtpd-local-delivery
+ (name "local")
+ (method "mbox")))
+ (options (list
+ (opensmtpd-option
+ (option "for local")))))
+ (opensmtpd-match
+ (action (opensmtpd-relay
+ (name "outbound")))
+ (options (list
+ (opensmtpd-option
+ (option "from local"))
+ (opensmtpd-option
+ (option "for any")))))))
+ ;; TODO perhaps I should sanitize this function like I sanitized
the 'filters'.
+ ;; 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?)))))
+ ;; 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?)))))
+ (smtp opensmtpd-configuration-smtp
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "smtp"
+ (list false? opensmtpd-smtp?)))))
+ (srs opensmtpd-configuration-srs
+ (default #f)
+ (sanitize (lambda (var)
+ (my/sanitize var "opensmtpd-configuration" "srs"
+ (list false? opensmtpd-srs?)))))
(setgid-commands? opensmtpd-setgid-commands? (default #t)))
+;; this help procedure is used 3 or 4 times by
sanitize-list-of-options-for-match-configuration
+(define* (throw-error-duplicate-option option error-arg #:key (record-name
"match"))
+ (throw-error error-arg
+ (list (string-append "<opensmtpd-" record-name ">'s fieldname
'options' has two\n")
+ (string-append "<opensmtpd-option> 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-options
+(define* (sanitize-list-of-options-for-match-configuration %options)
+ (let loop ((%traversing-options %options)
+ ;; sanitized-options is an alist that may end of looking like:
+ ;; (("for" (opensmtpd-option (option "for any")))
+ ;; ("from" (opensmtpd-option (option "from any"))))
+ (%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-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-data option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option> with fieldname
'option' with value 'helo' \n"
+ "must have a 'data' of type string
or <opensmtpd-table>.\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-data option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option> with fieldname
'option' with value 'mail-from' \n"
+ "must have a 'data' of type string
or <opensmtpd-table>.\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-data option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option> with fieldname
'option' with value 'rcpt-to' \n"
+ "must have a 'data' of type string
or <opensmtpd-table>.\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-data option-record)))
+ (throw-error option-record
+ (list "<opensmtpd-option> 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-data option-record)
+ (opensmtpd-option-regex option-record))
+ (throw-error option-record
+ (list "<opensmtpd-option> with fieldname
'option' with value 'tls', then \n"
+ "fieldname 'data' cannot be
defined.\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>'s fieldname
'options' can only have one 'for' option. \n"
+ "But '" ,option-string "' and '"
+ ,(opensmtpd-option-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-data option-record)
+ (opensmtpd-option-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-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> 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>'s fieldname
'options' can only have one 'from' option. \n"
+ "But '" ,option-string "' and '"
+ ,(opensmtpd-option-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-data option-record)
+ (opensmtpd-option-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-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> record.\n")))
+ (else (loop (cdr %traversing-options) (alist-cons
"from" option-record %sanitized-options))))))))))
+
+;; if the list of filters in opensmtpd-interface-filters
+;; and in opensmtpd-socket-configuration-filters has two
+;; filters with the same name, this will return #t
+;; otherwise false
+(define (duplicate-filter-name? %filters)
+ (contains-duplicate?
+ (let loop ((%filters %filters))
+ (if (null? %filters)
+ '()
+ (cond
+ ((opensmtpd-filter-phase? (car %filters))
+ (cons (opensmtpd-filter-phase-name (car %filters))
+ (loop (cdr %filters))))
+ (else
+ (cons (opensmtpd-filter-name (car %filters))
+ (loop (cdr %filters)))))))))
+
+(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-message record)
+ (opensmtpd-filter-phase-value record)))
+
+;; return #t if phase needs a message. Or if the message did not start with a
4xx or 5xx status code.
+;; otherwise #f
+(define (filter-phase-decision-lacks-proper-message? record)
+ (define decision (opensmtpd-filter-phase-decision record))
+ (if (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-message record))
+ #t)
+ ((string? (opensmtpd-filter-phase-message record))
+ (let ((number (string->number
+ (substring
+ (opensmtpd-filter-phase-message record) 0 3))))
+ (if (and (number? number)
+ (and (< number 600) (> number 399)))
+ #f
+ #t))))
+ #f))
+
+;; 'decision' "rewrite" requires 'value' to be a number.
+(define (filter-phase-lacks-proper-value? record)
+ (define decision (opensmtpd-filter-phase-decision record))
+ (if (string=? "rewrite" decision)
+ (if (and (number? (opensmtpd-filter-phase-value record))
+ (eq? #f (opensmtpd-filter-phase-message record)))
+ #f
+ #t)
+ #f))
+
+;; 'decision' "junk" or "bypass" cannot have a message or a value.
+(define (filter-phase-has-incorrect-junk-or-bypass? record)
+ (and
+ (string-in-list?
+ (opensmtpd-filter-phase-decision record)
+ (list "junk" "bypass"))
+ (or
+ (opensmtpd-filter-phase-value record)
+ (opensmtpd-filter-phase-message record))))
+
+(define (filter-phase-junks-after-commit? record)
+ (and (string=? (opensmtpd-filter-phase-decision record) "junk")
+ (string=? (opensmtpd-filter-phase-phase record) "commit")))
+
+;; returns #t if list is a unique list of <opensmtpd-filter> or
<opensmtpd-filter-phase>
+;; 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> or
<opensmtpd-filter>
+ (primitive-eval
+ (cons 'and (map (lambda (filter)
+ (or (opensmtpd-filter? filter)
+ (opensmtpd-filter-phase? filter)))
+ %filters)))
+ (not (contains-duplicate? %filters))))
+
+;; the sanitize procedures used for sanitizing <opensmtpd-interface> and
+;; <opensmtpd-socket-configuration> fieldname 'filters'.
+;; It primarily sanitizes <filter-phases>. The only sanitization it does
+;; for <filter>s, is no make sure there are no duplicate filter names.
+(define (sanitize-filter-phases %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-interface> fieldname: 'filters'
is a list, in which each unique element \n"
+ "is of type <opensmtpd-filter> or
<opensmtpd-filter-phase>.\n"))
+ (throw 'bad! %list)))
+ ((duplicate-filter-name? %list)
+ (throw-error %list (list "has a duplicate filter name.\n")
+ #:record-name "interface"
+ #:fieldname "filters"))
+ (else
+ (let loop ([%traversing-list %list]
+ [%original-list %list])
+ (if (null? %traversing-list)
+ %original-list
+ (cond [(opensmtpd-filter? (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>
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>
fieldname: 'decision' options \n"
+ "\"disconnect\" and \"reject\"
require fieldname 'message' to have an RFC \n"
+ "compliant string, which means
that the string 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>
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>
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>
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* (sanitize-options-for-filter-phase-configuration %options)
+ (if (false? %options)
+ (throw-error #f
+ (list "must have at least one opensmtpd-option record.")
+ #:record-name "filter-phase"
+ #:fieldname "options")
+ (let loop ((%traversing-options %options)
+ ;; sanitized-options is an alist that may end of looking like:
+ ;; (("for" (opensmtpd-option (option "for any")))
+ ;; ("from" (opensmtpd-option (option "from any"))))
+ (%sanitized-options '()))
+ (if (null? %traversing-options)
+ (remove false?
+ (list
+ (assoc-ref %sanitized-options "fcrdns")
+ (assoc-ref %sanitized-options "rdns")
+ (assoc-ref %sanitized-options "src")
+ (assoc-ref %sanitized-options "helo")
+ (assoc-ref %sanitized-options "auth")
+ (assoc-ref %sanitized-options "mail-from")
+ (assoc-ref %sanitized-options "rcpt-to")))
+ (let* ((option-record (car %traversing-options))
+ (option-string (opensmtpd-option-option option-record)))
+ (cond ((assoc-ref %sanitized-options option-string)
+ ;; if we see two "rdns" (for example), throw a "duplicate
+ ;; option" error.
+ (throw-error-duplicate-option option-string option-record
+ #:record-name
"filter-phase"))
+ ;; the next 4 options must have fieldname 'data' defined.
+ ((or (string=? option-string "src")
+ (string=? option-string "helo")
+ (string=? option-string "mail-from")
+ (string=? option-string "rcpt-to"))
+ (if (not (opensmtpd-table?
+ (opensmtpd-option-data option-record)))
+ (throw-error option-record (list "must have fieldname
'data' defined.\n")
+ #:record-name "option"
+ #:fieldname option-string)
+ (loop (cdr %traversing-options)
+ (alist-cons option-string option-record
%sanitized-options))))
+ ;;fcrdns cannot have fieldname data defined
+ ((string=? "fcrdns" option-string)
+ (if (opensmtpd-option-data option-record)
+ (throw-error option-record (list "cannot have
fieldname data defined.\n")
+ #:record-name "option"
+ #:fieldname "rdns")
+ (loop (cdr %traversing-options)
+ (alist-cons "fcrdns" option-record
%sanitized-options))))
+ ;; rdns and auth cannot be made invalidly; skip testing
them.
+ ((or (string=? "rdns" option-string)
+ (string=? "auth" option-string))
+ (loop (cdr %traversing-options)
+ (alist-cons "auth" option-record
+ %sanitized-options)))
+ (else (throw-error option-record
+ (list "has an invalid option name.")
+ #:record-name "filter-phase"
+ #:fieldname option-string))))))))
+
+(define* (throw-error var %strings
+ #:key
+ (record-name #f)
+ (fieldname #f))
+ (if (and record-name fieldname)
+ (begin
+ (display (string-append "<opensmtpd-" record-name "> fieldname "
fieldname " "
+ (apply string-append %strings)))
+ (throw 'bad! var))
+ (begin
+ (display (apply string-append %strings))
+ (throw 'bad! var))))
+
+;; this is used for sanitizing <opensmtpd-filter-phase> fieldname 'options'
+(define (contains-duplicate? list)
+ (if (null? list)
+ #f
+ (or
+ ;; check if (car list) is in (cdr list)
+ (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? list)
+ (and (list-of-type?
+ list opensmtpd-option?)
+ (not (contains-duplicate? list))))
+
+(define (list-of-opensmtpd-ca? list)
+ (list-of-type? list opensmtpd-ca?))
+
+(define (list-of-opensmtpd-pki? list)
+ (list-of-type? list opensmtpd-pki?))
+
+(define (list-of-opensmtpd-interface? list)
+ (and (list-of-type? list opensmtpd-interface?)
+ (not (contains-duplicate? list))))
+
+(define (list-of-unique-opensmtpd-match? list)
+ (and (list-of-type? list opensmtpd-match?)
+ (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> 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-type) procedure?
+(define (table-whose-data-are-assoc-list? table)
+ (if (not (opensmtpd-table? table))
+ #f
+ (assoc-list? (opensmtpd-table-data table))))
+
+;; this procedure takes in one argument
+;; if that argument is an <opensmtpd-table> whose fieldname 'values' is a list
of strings, then it returns
+;; #t, #f if otherwise.
+(define (table-whose-data-are-a-list-of-strings? table)
+ (if (not (opensmtpd-table? table))
+ #f
+ (list-of-strings? (opensmtpd-table-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))
+
+;; The following functions convert various records into strings.
+;;
+;; can be of type: (quote list-of-strings) or (quote assoc-list)
+(define (opensmtpd-table->string table)
+ (string-append "table " (opensmtpd-table-name table) " "
+ (let ((type (opensmtpd-table-type table)))
+ (cond ((eq? type (quote list-of-strings))
+ (string-append "{ " (list-of-strings->string
(opensmtpd-table-data table)
+
#:append "\""
+
#:drop-right-number 3
+
#:postpend "\"") " }"))
+ ((eq? type (quote assoc-list))
+ (string-append "{ " (assoc-list->string
(opensmtpd-table-data table)) " }"))
+ ((eq? type (quote db))
+ (string-append "db:" (opensmtpd-table-data table)))
+ ((eq? type (quote file))
+ (string-append "file:" (opensmtpd-table-data table)))
+ (else (throw 'youMessedUp table))))
+ " \n"))
+
+(define (opensmtpd-interface->string record)
+ (string-append "listen on "
+ (opensmtpd-interface-interface record) " "
+ (let* ((hostname (opensmtpd-interface-hostname record))
+ (hostnames (if (opensmtpd-interface-hostnames record)
+ (opensmtpd-table-name
(opensmtpd-interface-hostnames record))
+ #f))
+ (filters (opensmtpd-interface-filters record))
+ (filter-name (if filters
+ (if (< 1 (length filters))
+ (generate-filter-chain-name
filters)
+ (if (opensmtpd-filter? (car
filters))
+ (opensmtpd-filter-name (car
filters))
+ (opensmtpd-filter-phase-name
(car filters))))
+ #f))
+ (mask-src (opensmtpd-interface-mask-src record))
+ (tag (opensmtpd-interface-tag record))
+ (secure-connection
(opensmtpd-interface-secure-connection record))
+ (port (opensmtpd-interface-port record))
+ (pki (opensmtpd-interface-pki record))
+ (auth (opensmtpd-interface-auth record))
+ (auth-optional (opensmtpd-interface-auth-optional
record)))
+ (string-append
+ (if mask-src
+ (string-append "mask-src ")
+ "")
+ (variable->string hostname #:append "hostname ")
+ (variable->string hostnames #:append "hostnames <"
#:postpend "> ")
+ (variable->string filter-name #:append "filter \""
#:postpend "\" ")
+ (variable->string tag #:append "tag \"" #:postpend "\" ")
+ (if secure-connection
+ (cond ((string=? "smtps" secure-connection)
+ "smtps ")
+ ((string=? "tls" secure-connection)
+ "tls ")
+ ((string=? "tls-require" secure-connection)
+ "tls-require ")
+ ((string=? "tls-require-verify"
secure-connection)
+ "tls-require verify "))
+ "")
+ (variable->string port #:append "port " #:postpend " ")
+ (if pki
+ (variable->string (opensmtpd-pki-domain pki) #:append
"pki ")
+ "")
+ (if auth
+ (string-append "auth "
+ (if (opensmtpd-table? auth)
+ (string-append "<"
(opensmtpd-table-name auth) "> ")
+ ""))
+ "")
+ (if auth-optional
+ (string-append "auth-optional "
+ (if (opensmtpd-table? auth-optional)
+ (string-append "<"
(opensmtpd-table-name auth-optional) "> ")
+ ""))
+ "")
+ "\n"))))
+
+(define (opensmtpd-socket->string record)
+ (string-append "listen on socket "
+ (let* ((filters (opensmtpd-socket-configuration-filters
record))
+ (filter-name (if filters
+ (if (< 1 (length filters))
+ (generate-filter-chain-name
filters)
+ (if (opensmtpd-filter? (car
filters))
+ (opensmtpd-filter-name (car
filters))
+ (opensmtpd-filter-phase-name
(car filters))))
+ #f))
+ (mask-src (opensmtpd-socket-configuration-mask-src
record))
+ (tag (opensmtpd-socket-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-relay->string record)
+ (let ((backup (opensmtpd-relay-backup record))
+ (backup-mx (opensmtpd-relay-backup-mx record))
+ (helo (opensmtpd-relay-helo record))
+ ;; helo-src can either be a string IP address or an <opensmtpd-table>
+ (helo-src (if (opensmtpd-relay-helo-src record)
+ (if (string? (opensmtpd-relay-helo-src record))
+ (opensmtpd-relay-helo-src record)
+ (string-append "<\""
+ (opensmtpd-table-name
+ (opensmtpd-relay-src record))
+ "\">"))
+ #f))
+ (domain (if (opensmtpd-relay-domain record)
+ (opensmtpd-table-name
+ (opensmtpd-relay-domain record))
+ #f))
+ (host (opensmtpd-relay-host record))
+ (name (opensmtpd-relay-name record))
+ (pki (if (opensmtpd-relay-pki record)
+ (opensmtpd-pki-domain (opensmtpd-relay-pki record))
+ #f))
+ (srs (opensmtpd-relay-srs record))
+ (tls (opensmtpd-relay-tls record))
+ (auth (if (opensmtpd-relay-auth record)
+ (opensmtpd-table-name
+ (opensmtpd-relay-auth record))
+ #f))
+ (mail-from (opensmtpd-relay-mail-from record))
+ ;; src can either be a string IP address or an <opensmtpd-table>
+ (src (if (opensmtpd-relay-src record)
+ (if (string? (opensmtpd-relay-src record))
+ (opensmtpd-relay-src record)
+ (string-append "<\""
+ (opensmtpd-table-name
+ (opensmtpd-relay-src record))
+ "\">"))
+ #f)))
+
+ (string-append
+ "\""
+ name
+ "\" " "relay "
+ ;;FIXME should I always quote the host fieldname? do I need to quote
localhost via "localhost" ?
+ (variable->string host #:append "host \"" #:postpend "\" ")
+ (variable->string backup)
+ (variable->string backup-mx #:append "backup mx ")
+ (variable->string helo #:append "helo ")
+ (variable->string helo-src #:append "helo-src ")
+ (variable->string domain #:append "domain <\"" #:postpend "\"> ")
+ (variable->string host #:append "host ")
+ (variable->string pki #:append "pki ")
+ (variable->string srs)
+ (variable->string tls #:append "tls ")
+ (variable->string auth #:append "auth <" #:postpend "> ")
+ (variable->string mail-from #:append "mail-from ")
+ (variable->string src #:append "src ")
+ "\n")))
+
+(define (opensmtpd-lmtp->string record)
+ (string-append "lmtp "
+ (opensmtpd-lmtp-destination record)
+ (if (opensmtpd-lmtp-rcpt-to record)
+ (begin
+ " " (opensmtpd-lmtp-rcpt-to record))
+ "")))
+
+(define (opensmtpd-mda->string record)
+ (string-append "mda "
+ (opensmtpd-mda-command record) " "))
+
+(define (opensmtpd-maildir->string record)
+ (string-append "maildir "
+ "\""
+ (if (opensmtpd-maildir-pathname record)
+ (opensmtpd-maildir-pathname record)
+ "~/Maildir")
+ "\""
+ (if (opensmtpd-maildir-junk record)
+ " junk "
+ " ")))
+
+(define (opensmtpd-local-delivery->string record)
+ (let ((name (opensmtpd-local-delivery-name record))
+ (method (opensmtpd-local-delivery-method record))
+ (alias (if (opensmtpd-local-delivery-alias record)
+ (opensmtpd-table-name
+ (opensmtpd-local-delivery-alias record))
+ #f))
+ (ttl (opensmtpd-local-delivery-ttl record))
+ (user (opensmtpd-local-delivery-user record))
+ (userbase (if (opensmtpd-local-delivery-userbase record)
+ (opensmtpd-table-name
+ (opensmtpd-local-delivery-userbase record))
+ #f))
+ (virtual (if (opensmtpd-local-delivery-virtual record)
+ (opensmtpd-table-name
+ (opensmtpd-local-delivery-virtual record))
+ #f))
+ (wrapper (opensmtpd-local-delivery-wrapper record)))
+ (string-append
+ "\"" name "\" "
+ (cond ((string? method)
+ (string-append method " "))
+ ((opensmtpd-mda? method)
+ (opensmtpd-mda->string method))
+ ((opensmtpd-lmtp? method)
+ (opensmtpd-lmtp->string method))
+ ((opensmtpd-maildir? method)
+ (opensmtpd-maildir->string method)))
+ ;; FIXME/TODO support specifying alias file:/path/to/alias-file ?
+ ;; I do not think that is something that I can do...
+ (variable->string alias #:append "alias <\"" #:postpend "\"> ")
+ (variable->string ttl #:append "ttl ")
+ (variable->string user #:append "user ")
+ (variable->string userbase #:append "userbase <\"" #:postpend "\"> ")
+ (variable->string virtual #:append "virtual <" #:postpend "> ")
+ (variable->string wrapper #:append "wrapper "))))
+
+;; this function turns both opensmtpd-local-delivery and
+;; opensmtpd-relay into strings.
+(define (opensmtpd-action->string record)
+ (string-append "action "
+ (cond ((opensmtpd-local-delivery? record)
+ (opensmtpd-local-delivery->string record))
+ ((opensmtpd-relay? record)
+ (opensmtpd-relay->string record)))
+ " \n"))
+
+;; this turns option records found in <opensmtpd-match> into strings.
+(define* (opensmtpd-option->string record
+ #:key
+ (space-after-! #f))
+ (let ((not (opensmtpd-option-not record))
+ (option (opensmtpd-option-option record))
+ (regex (opensmtpd-option-regex record))
+ (data (opensmtpd-option-data record)))
+ (string-append
+ (if not
+ (if space-after-!
+ "! "
+ "!")
+ "")
+ option " "
+ (if regex
+ "regex "
+ "")
+ (if data
+ (if (opensmtpd-table? data)
+ (string-append "<" (opensmtpd-table-name data) "> ")
+ (string-append data " "))
+ ""))))
+
+(define (opensmtpd-match->string record)
+ (string-append "match "
+ (let* ((action (opensmtpd-match-action record))
+ (name (cond [(opensmtpd-relay? action)
+ (opensmtpd-relay-name action)]
+ [(opensmtpd-local-delivery? action)
+ (opensmtpd-local-delivery-name action)]
+ [else 'reject]))
+ (options (opensmtpd-match-options record)))
+ (string-append
+ (if options
+ (apply string-append
+ (map opensmtpd-option->string options))
+ "")
+ (if (string? name)
+ (string-append "action " "\"" name "\" ")
+ "reject ")
+ "\n"))))
+
+(define (opensmtpd-ca->string record)
+ (string-append "ca " (opensmtpd-ca-name record) " "
+ "cert \"" (opensmtpd-ca-file record) "\"\n"))
+
+(define (opensmtpd-pki->string record)
+ (let ((domain (opensmtpd-pki-domain record))
+ (cert (opensmtpd-pki-cert record))
+ (key (opensmtpd-pki-key record))
+ (dhe (opensmtpd-pki-dhe record)))
+ (string-append "pki " domain " " "cert \"" cert "\" \n"
+ "pki " domain " " "key \"" key "\" \n"
+ (if dhe
+ (string-append
+ "pki " domain " " "dhe " dhe "\n")
+ ""))))
+
+(define (generate-filter-chain-name list-of-filters)
+ (string-drop-right (apply string-append
+ (flatten
+ (map (lambda (filter)
+ (list
+ (if (opensmtpd-filter? filter)
+ (opensmtpd-filter-name filter)
+ (opensmtpd-filter-phase-name filter))
+ "-"))
+ list-of-filters)))
+ 1))
+
+;; this procedure takes in a list of <opensmtpd-filter> and
<opensmtpd-filter-phase>,
+;; 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? filter)
+ (opensmtpd-filter-name filter)
+ (opensmtpd-filter-phase-name filter))
+ "\", "))
+ list-of-filters)))
+ 2)
+ "}\n"))
+
+(define (opensmtpd-filter-phase->string record)
+ (let ((name (opensmtpd-filter-phase-name record))
+ (phase (opensmtpd-filter-phase-phase record))
+ (decision (opensmtpd-filter-phase-decision record))
+ (options (opensmtpd-filter-phase-options record))
+ (message (opensmtpd-filter-phase-message record))
+ (value (opensmtpd-filter-phase-value record)))
+ (string-append "filter "
+ "\"" name "\" "
+ "phase " phase " "
+ "match "
+ (apply string-append ; turn the options into a string
+ (flatten
+ (map (lambda (option)
+ (opensmtpd-option->string option
#:space-after-! #f))
+ options)))
+ " "
+ decision " "
+ (if (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>, <opensmtpd-filter-phase>,
+;; and lists that look like (list (opensmtpd-filter...)
(opensmtpd-filter-phase ...)
+;; ...)
+;; 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 ; 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->list-of-strings-and-gexps filters)
+ ;; first display the unique <opensmtpd-filter>s. and
<opensmtpd-filter-phase>s.
+ ;; to do this: flatten filters, then remove duplicates.
+ (list
+ (apply string-append
+ (map (lambda (filter)
+ (if (opensmtpd-filter-phase? filter)
+ (opensmtpd-filter-phase->string filter)
+ ""))
+ (delete-duplicates (flatten filters))))
+ ;; print out the filter-configurations
+ ;; would values and or call-with-values and or recieve work here?
+ (list (map (lambda (filter)
+ (if (opensmtpd-filter? filter)
+ (list "filter "
+ "\"" (opensmtpd-filter-name filter) "\" "
+ (if (opensmtpd-filter-exec filter)
+ "proc-exec "
+ "proc ")
+ "\"" (opensmtpd-filter-proc filter) "\""
+ "\n\n")
+ ""))
+ (delete-duplicates (flatten filters))))
+ ;; now we have to print the filter chains.
+ (apply string-append
+ (map (lambda (filter)
+ (cond ((list? filter)
+ (opensmtpd-filter-chain->string filter))
+ (else ; you are a <opensmtpd-filter>
+ "")))
+ filters))))
+
+(define (opensmtpd-configuration-listen->string string)
+ (string-append
+ "include \"" string "\"\n"))
+
+(define (opensmtpd-configuration-srs->string record)
+ (let ((key (opensmtpd-srs-key record))
+ (backup-key (opensmtpd-srs-backup-key record))
+ (ttl-delay (opensmtpd-srs-ttl-delay record)))
+ (string-append
+ (variable->string key #:append "srs key " #:postpend "\n")
+ (variable->string backup-key #:append "srs key backup " #:postpend "\n")
+ (variable->string ttl-delay #:append "srs ttl " #:postpend "\n")
+ "\n")))
+
+;; TODO make sure all options here work! I just fixed limit-max-rcpt!
+(define (opensmtpd-smtp->string record)
+ (let ((ciphers (opensmtpd-smtp-ciphers record))
+ (limit-max-mails (opensmtpd-smtp-limit-max-mails record))
+ (limit-max-rcpt (opensmtpd-smtp-limit-max-rcpt record))
+ (max-message-size (opensmtpd-smtp-max-message-size record))
+ (sub-addr-delim (opensmtpd-smtp-sub-addr-delim record)))
+ (string-append
+ (variable->string ciphers #:append "smtp ciphers " #:postpend "\n")
+ (variable->string limit-max-mails #:append "smtp limit max-mails "
#:postpend "\n")
+ (variable->string limit-max-rcpt #:append "smtp limit max-rcpt "
#:postpend "\n")
+ (variable->string max-message-size #:append "smtp max-message-size "
#:postpend "\n")
+ (variable->string sub-addr-delim #:append "smtp sub-addr-delim "
#:postpend "\n")
+ "\n")))
+
+(define (opensmtpd-configuration-queue->string record)
+ (let ((compression (opensmtpd-queue-compression record))
+ (encryption (opensmtpd-queue-encryption record))
+ (ttl-delay (opensmtpd-queue-ttl-delay record)))
+ (string-append
+ (if compression
+ "queue compression\n"
+ "")
+ (if encryption
+ (string-append
+ "queue encryption "
+ (if (not (boolean? encryption))
+ encryption
+ "")
+ "\n")
+ "")
+ (if ttl-delay
+ (string-append "queue ttl" ttl-delay "\n")
+ ""))))
+
+;; build a list of <opensmtpd-action> from
+;; opensmtpd-configuration-matches, which is a list of <opensmtpd-match>.
+;; Each <opensmtpd-match> has a fieldname 'action', which accepts an
<opensmtpd-action>.
+(define (get-opensmtpd-actions record)
+ (define opensmtpd-actions
+ (let loop ((list (opensmtpd-configuration-matches record)))
+ (if (null? list)
+ '()
+ (cons (opensmtpd-match-action (car list))
+ (loop (cdr list))))))
+ (delete-duplicates (append opensmtpd-actions)))
+
+;; build a list of opensmtpd-pkis from
+;; opensmtpd-configuration-listen-ons and
+;; get-opensmtpd-actions
+(define (get-opensmtpd-pkis record)
+ ;; TODO/FIXME/maybe/wishlist could get-opensmtpd-actions -> NOT have an
opensmtpd-relay?
+ ;; I think so. And if it did NOT have a relay configuration, then
action-pkis would be '() when
+ ;; it needs to be #f. because if the opensmtpd-configuration has NO pkis,
then this function will
+ ;; return '(), when it should return #f. If it returns '(), then
opensmtpd-configuration-fieldname->string will
+ ;; print the string "\n" instead of ""
+ (define action-pkis
+ (let loop1 ((list (get-opensmtpd-actions record)))
+ (if (null? list)
+ '()
+ (if (and (opensmtpd-relay? (car list))
+ (opensmtpd-relay-pki (car list)))
+ (cons (opensmtpd-relay-pki (car list))
+ (loop1 (cdr list)))
+ (loop1 (cdr list))))))
+ ;; FIXME/TODO/maybe/wishlist
+ ;; this could be #f aka left blank. aka there are no 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-interface-pki (car list))
+ (cons (opensmtpd-interface-pki (car list))
+ (loop2 (cdr list)))
+ (loop2 (cdr list))))))
+ (delete-duplicates (append action-pkis listen-on-pkis)))
+
+;; takes in a <opensmtpd-configuration> and returns a list whose elements are
<opensmtpd-filter>,
+;; <opensmtpd-filter-phase>, and a filter-chain.
+;; It returns a list of <opensmtpd-filter> and/or <opensmtpd-filter-phase>
+;; here's an example of what this procedure might return:
+;; (list (opensmtpd-filter...) (opensmtpd-filter-phase ...)
+;; (openmstpd-filter ...) (opensmtpd-filter-phase ...)
+;; ;; this next list is a filter-chain.
+;; (list (opensmtpd-filter-phase ...) (opensmtpd-filter...)))
+;;
+;; This procedure handles filter chains a little odd.
+(define (get-opensmtpd-filters record)
+ (define list-of-listen-on-records (if (opensmtpd-configuration-listen-ons
record)
+ (opensmtpd-configuration-listen-ons
record)
+ '()))
+
+ (define listen-on-socket-filters
+ (if (opensmtpd-socket-configuration-filters
(opensmtpd-configuration-listen-on-socket record))
+ (opensmtpd-socket-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-interface-filters
listen-on-record)
+ (= 1 (length
(opensmtpd-interface-filters
+ listen-on-record))))
+ (car (opensmtpd-interface-filters
listen-on-record))
+ (opensmtpd-interface-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>s assuming the thing you passed into it had
+;; any <opensmtpd-table>s.
+;;
+;; is object record? call func on it's fieldnames
+;; is object list? loop through it's fieldnames calling func on it's records
+;; is object #f or string? or '()? -> #f
+(define (get-opensmtpd-tables value)
+ (delete-duplicates
+ (remove boolean? (flatten ;; turn (list '(1) '(2 '(3))) -> '(1 2 3)
+ (cond ((opensmtpd-table? value)
+ value)
+ ((record? value)
+ (let* ((record-type (record-type-descriptor value))
+ (list-of-record-fieldnames
(record-type-fields record-type)))
+ (map (lambda (fieldname)
+ (get-opensmtpd-tables ((record-accessor
record-type fieldname) value)))
+ list-of-record-fieldnames)))
+ ((and (list? value) (not (null? value)))
+ (map get-opensmtpd-tables value))
+ (else #f))))))
+
+(define (opensmtpd-configuration-fieldname->string record fieldname-accessor
record->string)
+ (if (fieldname-accessor record)
+ (begin
+ (string-append
+ (list-of-records->string (fieldname-accessor record) record->string)
"\n"))
+ ""))
+
+(define (list-of-records->string list-of-records record->string)
+ (string-append
+ (cond ((not (list? list-of-records))
+ (record->string list-of-records))
+ (else
+ (let loop ([list list-of-records])
+ (if (null? list)
+ ""
+ (string-append
+ (record->string (car list))
+ (loop (cdr list)))))))))
+
+(define (opensmtpd-configuration->string record)
+ (string-append
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-bounce
+ (lambda (%bounce)
+ (if %bounce
+ (list-of-strings->string
%bounce)
+ "")))
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-smtp
+ opensmtpd-smtp->string)
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-srs
+
opensmtpd-configuration-srs->string)
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-queue
+
opensmtpd-configuration-queue->string)
+ ;; write out the mta-max-deferred
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-mta-max-deferred
+ (lambda (var)
+ (string-append "mta max-deferred "
+ (number->string (opensmtpd-configuration-mta-max-deferred
record)) "\n")))
+ ;;write out all the tables
+ (opensmtpd-configuration-fieldname->string record get-opensmtpd-tables
opensmtpd-table->string)
+ ;; write out all the cas
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-cas opensmtpd-ca->string)
+ ;; write out all the pkis
+ (opensmtpd-configuration-fieldname->string record get-opensmtpd-pkis
opensmtpd-pki->string)
+ ;; write all of the listen-on-records
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-listen-ons
+ opensmtpd-interface->string)
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-listen-on-socket
+ opensmtpd-socket->string)
+ ;; write all the actions
+ (opensmtpd-configuration-fieldname->string record get-opensmtpd-actions
+ opensmtpd-action->string)
+ ;; write all of the matches
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-matches opensmtpd-match->string)))
+
+;; FIXME/TODO should I use format here srfi-28 ?
+;; web.scm nginx does a (format #f "string" "another string")
+;; this could be a list like (list (file-append opensmtpd-dkimsign
"/libexec/filter") "-d gnucode.me -s /path/to/selector.cert")
+;; Then opensmtpd-configuration->mixed-text-file could be rewritten to be
something like
+;; (mixed-text-file (eval `(string-append
(opensmtpd-configuration-fieldname->string ...)) (gnu services mail)))
+(define (opensmtpd-configuration->mixed-text-file record)
+ ;; 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)))))
+
+ (apply mixed-text-file "smtpd.conf"
+ ;; write out the includes
+ (flatten (list
+ (opensmtpd-configuration-fieldname->string record
opensmtpd-configuration-includes
+
opensmtpd-configuration-listen->string)
+ ;; TODO should I change the below line of code into these
two lines of code?
+ ;;(opensmtpd-configuration-fieldname->string record
get-opensmtpd-filters-and-filter-phases
opensmtpd-filter-and-filter-phase->string)
+ ;;(opensmtpd-configuration-fieldname->string record
get-opensmtpd-filter-chains opensmtpd-filter-chain->string)
+ ;; write out all the filters
+ (opensmtpd-filters->list-of-strings-and-gexps
(get-opensmtpd-filters record))
+ (opensmtpd-configuration->string record)))))
+
+
(define %default-opensmtpd-config-file
(plain-file "smtpd.conf" "
listen on lo
@@ -1668,7 +3724,7 @@ (define %default-opensmtpd-config-file
match from local for any action outbound
"))
-(define opensmtpd-shepherd-service
+(define (opensmtpd-shepherd-service config)
(match-lambda
(($ <opensmtpd-configuration> package config-file)
(list (shepherd-service
@@ -1677,7 +3733,8 @@ (define opensmtpd-shepherd-service
(documentation "Run the OpenSMTPD daemon.")
(start (let ((smtpd (file-append package "/sbin/smtpd")))
#~(make-forkexec-constructor
- (list #$smtpd "-f" #$config-file)
+ (list #$smtpd "-f" (or #$config-file
+
#$(opensmtpd-configuration->mixed-text-file config)))
#:pid-file "/var/run/smtpd.pid")))
(stop #~(make-kill-destructor)))))))
@@ -1700,10 +3757,11 @@ (define %opensmtpd-accounts
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
-(define opensmtpd-activation
+(define (opensmtpd-activation config)
(match-lambda
(($ <opensmtpd-configuration> package config-file)
- (let ((smtpd (file-append package "/sbin/smtpd")))
+ (let ((smtpd (file-append package "/sbin/smtpd"))
+ (configuration (opensmtpd-configuration->mixed-text-file config)))
#~(begin
(use-modules (guix build utils))
;; Create mbox and spool directories.
@@ -1711,7 +3769,12 @@ (define opensmtpd-activation
(mkdir-p "/var/spool/smtpd")
(chmod "/var/spool/smtpd" #o711)
(mkdir-p "/var/spool/mail")
- (chmod "/var/spool/mail" #o711))))))
+ (chmod "/var/spool/mail" #o711)
+ (display (string-append "checking syntax of "
+ (or
+ #$config-file
+ #$configuration)
+ "\n")))))))
(define %opensmtpd-pam-services
(list (unix-pam-service "smtpd")))
diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm
index f13751b72f..1bac9f50a2 100644
--- a/gnu/tests/mail.scm
+++ b/gnu/tests/mail.scm
@@ -37,6 +37,7 @@ (define-module (gnu tests mail)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (ice-9 ftw)
+ #:use-module (srfi srfi-64)
#:export (%test-opensmtpd
%test-exim
%test-dovecot
@@ -165,6 +166,360 @@ (define %test-opensmtpd
(description "Send an email to a running OpenSMTPD server.")
(value (run-opensmtpd-test))))
+;; trying to create a bad record, should result in an error.
+;; this function should be able return, instead it should throw an error
+(define (create-bad-record record)
+ ;; TODO why is this not working
+ (with-output-to-port (%make-void-port "w")
+ (lambda () (when record #f))))
+
+;; if this caller function is reached, then trying to create the bad record
+;; resulted in an error. So return true.
+(define (return-true error arg)
+ #t)
+
+;; two filters with the same name
+(define (bad-interface1)
+ (create-bad-record
+ (opensmtpd-interface
+ (interface "lo")
+ (filters (list
+ (opensmtpd-filter
+ (name "dkimsign")
+ (exec #t)
+ (proc (list (file-append opensmtpd-filter-dkimsign
"/libexec/opensmtpd/filter-dkimsign")
+ " -d gnucode.me -s 2021-09-22 -c relaxed/relaxed -k
"
+ "rando string"
+ "/etc/dkim/private.key "
+ "user nobody group nogroup")))
+ (opensmtpd-filter
+ (name "dkimsign")
+ (exec #t)
+ (proc (list (file-append opensmtpd-filter-dkimsign
"/libexec/opensmtpd/filter-dkimsign")
+ " -d gnucode.me -s 2021-09-22 -c relaxed/relaxed -k
"
+ "/etc/dkim/private.key "
+ "user nobody group nogroup"))))))))
+
+;; duplicate filter names
+(define (bad-interface2)
+ (create-bad-record
+ (opensmtpd-interface
+ (filters (list
+ (opensmtpd-filter-phase
+ (name "src")
+ (phase "connect")
+ (options
+ (list
+ (opensmtpd-option
+ (option "fcrdns")
+ (not #t))))
+ (decision "junk"))
+ (opensmtpd-filter-phase
+ (name "src")
+ (phase "helo")
+ (options
+ (list
+ (opensmtpd-option
+ (option "rdns")
+ (not #t))))
+ (decision "junk")))))))
+
+ ;; improper phase name
+(define (bad-filter-phase1)
+ (create-bad-record
+ (opensmtpd-filter-phase
+ (name "filter")
+ (phase "wrongString")
+ (decision "bypass")
+ (options
+ (list
+ (opensmtpd-option
+ (option "auth")))))))
+
+;; decision reject requires you to have a
+;; corresponding fieldname 'message' with value of string.
+(define (bad-filter-phase2)
+ (create-bad-record
+ (opensmtpd-interface
+ (filters (list
+ (opensmtpd-filter-phase
+ (name "src")
+ (phase "connect")
+ (options
+ (list
+ (opensmtpd-option
+ (option "src")
+ (data (opensmtpd-table
+ (name "src-table")
+ (data (list "cat" "hat")))))))
+ (decision "reject")))))))
+
+;; message needs to start with 4xx or 5xx
+(define (bad-filter-phase3)
+ (create-bad-record
+ (opensmtpd-interface
+ (filters (list
+ (opensmtpd-filter-phase
+ (name "src")
+ (phase "connect")
+ (options
+ (list
+ (opensmtpd-option
+ (option "src")
+ (data (opensmtpd-table
+ (name "src-table")
+ (data (list "cat" "hat")))))))
+ (decision "reject")
+ (message "322 Bad data!")))))))
+
+ ;; there needs to be a value here. rewrite requires a value!
+(define (bad-filter-phase4)
+ (create-bad-record
+ (opensmtpd-interface
+ (filters
+ (list
+ (opensmtpd-filter-phase
+ (name "noFRDNS")
+ (phase "commit")
+ (options (list (opensmtpd-option
+ (option "fcrdns")
+ (not #t))))
+ (decision "rewrite"))
+ )))))
+
+;; fieldname 'decision' with value "junk" or "bypass", then fieldname
'message' and 'value'
+;; must NOT be defined
+(define (bad-filter-phase5)
+ (create-bad-record
+ (opensmtpd-interface
+ (filters
+ (list
+ (opensmtpd-filter-phase
+ (name "noFRDNS")
+ (phase "commit")
+ (options (list (opensmtpd-option
+ (option "fcrdns")
+ )))
+ (decision "junk")
+ (message "This is not a good email.")))))))
+
+;; you cannot junk on phase commit. You need to use an eariler phase.
+(define (bad-filter-phase6)
+ (create-bad-record
+ (opensmtpd-interface
+ (filters
+ (list
+ (opensmtpd-filter-phase
+ (name "junk-after-commit")
+ (options (list (opensmtpd-option
+ (option "fcrdns"))))
+ (phase "commit")
+ (decision "junk")))))))
+
+;; TODO fix this test
+;; two fcrdns options records
+(define (bad-filter-phase7)
+ (create-bad-record
+ (opensmtpd-filter-phase
+ (name "invalid-fcrdns")
+ (phase "connect")
+ (options
+ (list (opensmtpd-option
+ (option "fcrdns")
+ (not #t))
+ (opensmtpd-option
+ (option "fcrdns")
+ (not #f))))
+ (decision "reject")
+ (message "422 No valid fcrdns."))))
+
+;; option src requires a table
+;; TODO maybe check for other options requiring a table
+(define (bad-filter-phase8)
+ (create-bad-record
+ (opensmtpd-filter-phase
+ (name "filter")
+ (phase "helo")
+ (decision "bypass")
+ (options
+ (list
+ (opensmtpd-option
+ (option "src")))))))
+
+;; option fcrdns cannot have data defined.
+(define (bad-filter-phase9)
+ (create-bad-record
+ (opensmtpd-filter-phase
+ (name "filter")
+ (phase "helo")
+ (decision "bypass")
+ (options
+ (list
+ (opensmtpd-option
+ (option "fcrdns")
+ (data (opensmtpd-table
+ (name "table")
+ (data (list "hello" "cat"))))))))))
+
+
+;; this should be (list ...) instead of '( ...)
+(define (bad-match1)
+ (create-bad-record
+ (opensmtpd-match
+ (options
+ '((opensmtpd-option
+ (option "for any"))))
+ (action
+ (opensmtpd-relay)))))
+
+
+;; duplcate "for" options
+(define (bad-match2)
+ (create-bad-record
+ (opensmtpd-match
+ (options (list
+ (opensmtpd-option
+ (option "for any"))
+ (opensmtpd-option
+ (option "for local"))))
+ (action
+ (opensmtpd-relay
+ (name "relay"))))))
+
+;; duplicate froms
+(define (bad-match3)
+ (create-bad-record
+ (opensmtpd-match
+ (options (list
+ (opensmtpd-option
+ (option "from any"))
+ (opensmtpd-option
+ (option "from auth"))))
+ (action
+ (opensmtpd-relay
+ (name "relay"))))))
+
+;; rcpt-to must have a data field.
+(define (bad-match4)
+ (create-bad-record
+ (opensmtpd-match
+ (options (list
+ (opensmtpd-option
+ (option "rcpt-to"))))
+ (action
+ (opensmtpd-relay
+ (name "relay"))))))
+
+;; option 'tls' cannot have fieldname
+;; 'data' defined.
+(define (bad-match5)
+ (create-bad-record
+ (opensmtpd-match
+ (options (list
+ (opensmtpd-option
+ (option "tls")
+ (data "hello"))))
+ (action
+ (opensmtpd-relay
+ (name "relay"))))))
+
+;; for any cannot have data
+;; or regex defined
+(define (bad-match6)
+ (create-bad-record
+ (opensmtpd-match
+ (options (list
+ (opensmtpd-option
+ (option "for any")
+ (regex #t))))
+ (action
+ (opensmtpd-relay
+ (name "relay"))))))
+
+;; match needs an action
+(define (bad-match7)
+ (create-bad-record
+ (opensmtpd-match
+ (options (list
+ (opensmtpd-option
+ (option "from auth")))))))
+
+(define (run-opensmtpd-record-sanitation-test)
+ ;(with-output-to-port (%make-void-port
"w")
+ ; (lambda ()
+ (test-begin "run-opensmtpd-record-sanitation-test")
+
+ ;; TODO fix me!
+ (test-assert "Test <interface> fieldname 'filters' has two filters with the
same name."
+ (catch #t bad-interface1 return-true))
+
+ (test-assert "Test <interface> cannot have two filters with the same name."
+ (catch #t bad-interface2 return-true))
+
+ (test-assert "Test <filter-phase> fieldname 'phase' the right string."
+ (catch #t bad-filter-phase1 return-true))
+
+ (test-assert "Test <filter-phase> fieldname 'decision' w/ value \"reject\"
and \"disconnect\" requires a 'message'."
+ (catch #t bad-filter-phase2 return-true))
+
+ (test-assert (string-append "Test <filter-phase> fieldname 'decision' "
+ "w/ value \"reject\" and \"disconnect\"
requires a 'message'."
+ " The message must begin with 4xx or 5xx.")
+ (catch #t bad-filter-phase3 return-true))
+
+ (test-assert "Test <filter-phase> fieldname 'rewrite' requires fieldname
'value' to have a number."
+ (catch #t bad-filter-phase4 return-true))
+
+ (test-assert (string-append "Test <filter-phase> fieldname 'decision' with
values 'junk' or 'bypass', "
+ "then fieldname 'message' and 'value' must be
blank.")
+ (catch #t bad-filter-phase5 return-true))
+
+ (test-assert "You cannot junk an email on phase commit."
+ (catch #t bad-filter-phase6 return-true))
+
+ ;; TODO fix me!
+ (test-assert "Test <filter-phase> has 2 duplicate options."
+ (catch #t bad-filter-phase7 return-true))
+
+ (test-assert "Test <filter-phase> option 'src' requires a table."
+ (catch #t bad-filter-phase8 return-true))
+
+ ;; TODO fix me!
+ (test-assert "Test <filter-phase> option 'fcrdns' cannot have a table."
+ (catch #t bad-filter-phase9 return-true))
+
+ (test-assert "Test <opensmtpd-match> fieldname 'options' should not be
quoted."
+ (catch #t bad-match1 return-true))
+
+ (test-assert "Test <opensmtpd-match> has duplicate 'for' options."
+ (catch #t bad-match2 return-true))
+
+ (test-assert "Test <opensmtpd-match> has duplicate 'from' options."
+ (catch #t bad-match3 return-true))
+
+ (test-assert "Test <opensmtpd-match> option 'rcpt' must have data."
+ (catch #t bad-match4 return-true))
+
+ (test-assert "Test <opensmtpd-match> option 'tls' cannot have fieldname
'data' defined."
+ (catch #t bad-match5 return-true))
+
+ (test-assert "Test <opensmtpd-match> option 'for any' cannot have fieldname
'data' defined."
+ (catch #t bad-match6 return-true))
+
+ (test-assert "Test <opensmtpd-match> needs fieldname 'action' needs to be
defined."
+ (catch #t bad-match7 return-true))
+
+ (test-end "run-opensmtpd-record-sanitation-test"))
+
+(define %test-opensmtpd-record-sanitation
+ (system-test
+ (name "opensmtpdRecordSanitation")
+ (description
+ (string-append "<opensmtpd> has numerous sanity checks.\n"
+ "This checks that invalid configurations, return an\n"
+ "appropriate error.\n"))
+ (value (run-opensmtpd-record-sanitation-test))))
+
(define %exim-os
(simple-operating-system
base-commit: 4b3493ed0156709a924f31ef4c9a5efa0815dfe8
--
2.38.0
- [bug#56046] [Patch master v2] services (opensmtpd): add opensmtpd records to enhance opensmtpd-configuration.,
Joshua Branson <=