From debbugs-submit-bounces@debbugs.gnu.org Fri Dec 23 11:40:07 2022 Received: (at 56046) by debbugs.gnu.org; 23 Dec 2022 16:40:07 +0000 Received: from localhost ([127.0.0.1]:37697 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p8l5b-00076j-A2 for submit@debbugs.gnu.org; Fri, 23 Dec 2022 11:40:07 -0500 Received: from mx1.dismail.de ([78.46.223.134]:11956) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p8l5Z-00076G-5m for 56046@debbugs.gnu.org; Fri, 23 Dec 2022 11:40:05 -0500 Received: from mx1.dismail.de (localhost [127.0.0.1]) by mx1.dismail.de (OpenSMTPD) with ESMTP id e529fbc4 for <56046@debbugs.gnu.org>; Fri, 23 Dec 2022 17:39:56 +0100 (CET) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed; d=dismail.de; h=from:to:cc :subject:date:message-id:mime-version:content-type :content-transfer-encoding; s=20190914; bh=2HnqPZ5olFQe8Rdw7tzw2 B9E9ba+BwOdvQlx5L9fGfY=; b=STudcGdFOId7IPo7PQfIqB+yGIRd07nsG3W6i oo9rmIeance+PI6dgwObqwNgKSMs15Bst9+B0MmtsaMhMrFbWosIZt04mOTCJY8N JypshTvX6/q+yAK1Xez3CI6kknefCLG65vUpZJEr1FBjeC80IvAzbwuTK/hg1aRn 7FWYOg03x1fKK1a1kUnloWHlqM6KRAoVva2y8t4ALjwSEuH+wyZ7QjS+dsxJVoXH 2mA4zt2boGE6YcUjujXr0AhgUUtiEbq0wjYCFvYhrBJWF1Fnt6KJwRT6NcYhf/7F P8kN0dUhbGDkECgNvYkmUf5ZrZ1UnLub17WiNAeVCL/0qQ20Q== Received: from smtp1.dismail.de ( [10.240.26.11]) by mx1.dismail.de (OpenSMTPD) with ESMTP id 179392cb for <56046@debbugs.gnu.org>; Fri, 23 Dec 2022 17:39:56 +0100 (CET) Received: from smtp1.dismail.de (localhost [127.0.0.1]) by smtp1.dismail.de (OpenSMTPD) with ESMTP id 85c289a2 for <56046@debbugs.gnu.org>; Fri, 23 Dec 2022 17:39:56 +0100 (CET) Received: by dismail.de (OpenSMTPD) with ESMTPSA id c1994ee4 (TLSv1.3:TLS_AES_256_GCM_SHA384:256:NO); Fri, 23 Dec 2022 17:39:49 +0100 (CET) From: Joshua Branson To: 56046@debbugs.gnu.org Subject: [PATCH opensmtpd-records v4 fixing charset=y error] services (opensmtpd): add opensmtpd records to enhance opensmtpd-configuration. Date: Fri, 23 Dec 2022 11:39:20 -0500 Message-Id: <8001f404c0e54baba71ef9c5536abc54275c4167.1671813513.git.jbranso@dismail.de> X-Mailer: git-send-email 2.38.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Debbugs-Envelope-To: 56046 Cc: Joshua Branson X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" Whoops the last sent patch had some charset=y errors. Hopefully this is better. This is V3 of my opensmtp records configuration. Hopefully soon, I will have this WIP service is guixrus, so more people can easily play with it. https://git.sr.ht/~whereiseveryone/guixrus BUT the new milestone is this, I am now actually able to use opensmtpd on my gnucode.me account! So that is pretty awesome! Here is a link to my server config: https://notabug.org/jbranso/linode-guix-system-configuration/src/master/linode-locke-lamora-current-config.scm The best place to find documentation for this service is here: https://notabug.org/jbranso/linode-guix-system-configuration/src/master/opensmtpd-records-documentation.txt 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, opensmtpd-ca, opensmtpd-pki, opensmtpd-action-local-delivery, opensmtpd-maildir, opensmtpd-mda, opensmtpd-lmtp, opensmtpd-relay, opensmtpd-option, opensmtpd-filter-phase, opensmtpd-filter, opensmtpd-interface, opensmtpd-socket, opensmtpd-match, opensmtpd-smtp, opensmtpd-srs, opensmtpd-queue, 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, 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?, list-of-opensmtpd-ca?, list-of-opensmtpd-pki?, list-of-opensmtpd-listen-on?, list-of-unique-opensmtpd-match?, list-of-strings->string, assoc-list? assoc-list, variable->string, tables-data-are-assoc-list?, tables-data-are-a-list-of-strings?, table-data-are-a-nested-list-of-strings?, assoc-list->string, opensmtpd-table->string, opensmtpd-listen-on->string, opensmtpd-listen-on-socket->string, opensmtpd-action-relay->string, opensmtpd-lmtp->string, opensmtpd-mda->string, opensmtpd-maildir->string, opensmtpd-action-local-delivery->string, opensmtpd-action->string, opensmtpd-option->string, opensmtpd-match->string, opensmtpd-ca->string, opensmtpd-pki->string, generate-filter-chain-name, opensmtpd-filter-chain->string, opensmtpd-filter-phase->string, opensmtpd-filters->string, opensmtpd-listen->string, opensmtpd-srs->string, opensmtpd-smtp->string, opensmtpd-queue->string, get-opensmtpd-actions, get-opensmtpd-pkis, get-opensmtpd-filters, flatten, get-opensmtpd-tables, opensmtpd-fieldname->string, list-of-records->string, opensmtpd->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 | 1065 ++++++++++++++++- gnu/services/mail.scm | 2560 ++++++++++++++++++++++++++++++++++++++++- gnu/tests/mail.scm | 713 ++++++++++++ 3 files changed, 4310 insertions(+), 28 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 535c8cdfc3..879a2ad233 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -25407,16 +25407,66 @@ could instantiate a dovecot service like this: @end lisp @subsubheading OpenSMTPD Service +@cindex opensmtpd @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: +OpenSMTPD is an easy-to-use mail transfer agent (MTA). OpenSMTPD +@strong{listens} for incoming mail and @strong{matches} the mail to +@strong{actions}. The following records represent those stages: -@lisp -(service opensmtpd-service-type - (opensmtpd-configuration - (config-file (local-file "./my-smtpd.conf")))) +@multitable {aaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} +@item @strong{listens} +@tab @code{} +@item +@tab @code{} +@item +@tab +@item @strong{matches} +@tab @code{} +@item +@tab +@item @strong{actions} +@tab @code{} +@item +@tab @code{} +@end multitable + +Additionally, each @code{} and +@code{} may use a list of @code{}, +and/or @code{} records to filter +email/spam. Also numerous records' fieldnames use +@code{} records to hold lists or key value pairs of +data. Be sure to read the @code{} section to learn the +differance between a @code{mapping table} and a @code{list table}. + +Finally, both @code{} and +@code{} use @code{} to +configure various options. + +A simple example opensmtpd 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 + (interfaces (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 @@ -25425,7 +25475,7 @@ Data type representing the configuration of opensmtpd. @table @asis @item @code{package} (default: @var{opensmtpd}) -Package object of the OpenSMTPD SMTP server. +Package object of the OpenSMTPD server. @item @code{config-file} (default: @code{%default-opensmtpd-config-file}) File-like object of the OpenSMTPD configuration file to use. By default @@ -25433,14 +25483,1013 @@ 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. +@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 a specified delay. Each delay option +is a string parameter beginning with a positive decimal integer and a +unit, which can be 's', 'm', 'h', or 'd'. At most four delay parameters +can be specified. + +@item @code{interfaces} default: +@lisp +(list + (opensmtpd-interface + (interface "lo") + (port 25))) +@end lisp +@code{interfaces} is a list of @code{} records. +This list details what interfaces and ports OpenSMTPD listens on as well as +other options. + +@item @code{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. Run @code{man smtpd.conf} for more information. + +@item @code{matches} default: +@lisp +(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")))))) +@end lisp +@code{matches} is a list of @code{} records, which +matches incoming mail and sends it to a correspending action. The match +records are evaluated sequentially, with the first match winning. +Therefore @emph{the order that you arrange your matches is important}. +It's a good idea to put specific matches first and an all emcompassing +match (like @code{(option "for any")}) @strong{last}. If an incoming +mail does not match any match records, then it is rejected. + +@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{} 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{} 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{} 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. + @end table @end deftp +@itemize +@item Data Type: opensmtpd-interface +Data type representing the configuration of an +@code{}. It listens on the fieldname +@code{interface} for incoming connections, using the same syntax as +@code{ifconfig}. 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 via the fieldname +@code{family}, which can be either @code{"inet4"} or @code{"inet6"}. + +@itemize +@item @code{interface} (default: @code{"lo"}) + +The string interface to listen for incoming connections. This string +may be an interface group, an IP address, or a domain name. These +interfaces can usually be found by the command @code{ip link}. + +@item @code{family} (default: @code{#f}) + +Only listen on a specific address family. Valid strings are +@code{"inet4"} or @code{"inet6"}, which will only listen on IPv4 or IPv6 +respectfully. If @code{(family #f)}, then opensmtpd will listen on both +IPv4 and IPv6. + +@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 a @code{mapping table} that maps usernames to +encrypted passwords. The password can be encrypted via the +@code{smtpctl} @code{encrypt} subcommand. + +@item @code{auth-optional} (default: @code{#f}) +Support SMTPAUTH optionally: clients need not authenticate, but may do +so. This allows the @code{} to both accept +incoming mail from untrusted senders and permit outgoing mail from +authenticated users. 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. This option also accepts a @code{mapping +table} that maps usernames to encrypted passwords. + +@item @code{filters} (default: @code{#f}) +A list of one or many @code{} or +@code{} records. The filters are applied +sequentially. These records listen and filter on connections handled by this +listener. + +@item @code{hostname} (default: @code{#f}) +Change the default server name in the greeting banner instead of the +default one. + +@item @code{hostnames} (default: @code{#f}) +Override the server name for specific addresses. Use a @code{mapping +table} that maps string IP addresses to string 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{} record to prove a +mail server's identity. + +@item @code{port} (default: @code{25}) +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{mapping table} to +find the email addresses that user is allowed to submit mail as. + +@item @code{masquerade} (default: @code{#f}) +@code{masquerade}, is used in conjunction with @code{senders}. If +@code{#t}, then the From header is rewritten to match the sender +provided in the SMTP session. If @code{senders} is @code{#false}, then +@code{masquerade} cannot be @code{#t}. + +@item @code{secure-connection} (default: @code{#f}) +This is a string of one of these options: + +@multitable {aaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} +@item @code{"smtps"} +@tab Support SMTPS, by default on port 465. +@item @code{"tls"} +@tab Support STARTTLS, by default on port 25. +@item @code{"tls-require"} +@tab Like @code{"tls"}, but force clients to +@item +@tab establish a secure connection before being +@item +@tab allowed to start an SMTP transaction. +@item @code{"tls-require-verify"} +@tab Like @code{"tls-require"}, but clients must +@item +@tab also provide a valid certificate +@item +@tab 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{}. Listen for incoming SMTP connections on the +Unix domain socket @samp{/var/run/smtpd.sock}. This is done by default, +even if the record is absent. + +@itemize +@item @code{filters} (default: @code{#f}) +A list of one or many @code{} or +@code{} 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 +@cindex opensmtpd-match +This data type represents the configuration of an +@code{} 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{} found in fieldname +@code{action}. Here is an example @code{opensmtpd-match} +record. + +@lisp +(opensmtpd-match + (action (opensmtpd-local-delivery + (name "receive") + (method (opensmtpd-maildir + (pathname "/home/%@{rcpt.user@}/Maildir") + (junk #t))) + (virtual (opensmtpd-table + (name "virt") + (data '(("carmen" . "carmen@@gnu.org"))))))) + (options (list (opensmtpd-option + (option "from any")) + (opensmtpd-option + (option "for domain") + (data (opensmtpd-table + (name "domain-table") + (data (list "gnu.org" "fsf.org")))))))) +@end lisp + +@itemize +@item @code{action} (default: @code{#f}) + +If mail matches this match configuration, then do this action. Valid values +include @code{} or +@code{}. + +@item @code{options} (default: @code{#f}) +The fieldname @code{option} is a list of unique +@code{} records. + +There are 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 @code{"for any"} +@tab @code{"from any"} +@item @code{"for local"} +@tab @code{"from auth"} +@item @code{"for domain"} +@tab @code{"from local"} +@item @code{"for rcpt-to"} +@tab @code{"from mail-from"} +@item +@tab @code{"from socket"} +@item +@tab @code{"from src"} +@end multitable + +Additionally, some options require additional data via +@code{}'s fieldname @code{data}. The following list +will explain the below syntax. + +@itemize +@item @code{"for any"} +This option only requires fieldname @code{option} to have the string +@code{"for any"}: + +@lisp + (opensmtpd-option + (option "for any")) +@end lisp + +@item @code{"tag"} _tag_ +This option only requires fieldname @code{option} to have the string +@code{"tag"} with a string in fieldname @code{data}: + +@lisp + (opensmtpd-option + (option "tag") + (data "this-tag")) +@end lisp + +@item @code{"for rcpt"} _domain_ | +This option requires fieldname @code{data} to have a string domain or +@code{list table}: + +@lisp + (opensmtpd-option + (option "for rcpt") + (data "gnu.org")) +@end lisp + +OR + +@lisp + (opensmtpd-option + (option "for rcpt") + (data (list "gnu.org" "fsf.org"))) +@end lisp +@end itemize + +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: ), also support specifying regex via (regex #t). + +@itemize +@item @code{"for any"} +Specify that session may address any destination. + +@item @code{"for local"} +Specify that session may address any local domain. This is the default, +and may be omitted. + +@item @code{"for domain"} _domain_ | +Specify that session may address the string _domain_ or +@code{list table} . + +@item @code{"for rcpt-to"} _recipient_ | +Specify that session may address the string _recipient_ or list table +. + +@item @code{"from any"} +Specify that session may originate from any source. + +@item @code{"from auth"} +Specify that session may originate from any authenticated user, no matter +the source IP address. + +@item @code{"from auth"} _user_ | +Specify that the session may originate from authenticated _user_ or +@code{list table} , no matter the source IP address. + +@item @code{"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 @code{"from mail-from"} _sender_ | +Specify that session may originate from _sender_ or @code{list table} +, no matter the source IP address. + +@item @code{"from rdns"} +Specify that session may only originate from an IP address that resolves +to a reverse DNS@. + +@item @samp{"from rdns"} _hostname_ | +Specify that session may only originate from an IP address that resolves +to a reverse DNS matching string _hostname_ or @code{list table} +. + +@item @samp{"from socket"} +Specify that session may only originate from the local enqueuer. + +@item @code{"from src"} _address_ |
+Specify that session may only originate from string _address_ or +@code{list table}
which can be a specific address or a subnet +expressed in CIDR-notation. + +@item @code{"auth"} +Matches transactions which have been authenticated. + +@item @code{"auth"} _username_ | +Matches transactions which have been authenticated for string _user_ or +@code{list table} . + +@item @code{"helo"} _helo-name_ | +Specify that session's HELO / EHLO should match the string _helo-name_ +or @code{list table} . + +@item @code{"mail-from"} _sender_ | +Specify that transactions's MAIL FROM should match the string _sender_ +or @code{list table} . + +@item @code{"rcpt-to"} _recipient_ | +Specify that transaction's RCPT TO should match the string _recipient_ +or @code{list table} . + +@item @code{"tag"} _tag_ +Matches transactions tagged with the given tag. + +@item @code{"tls"} +Specify that transaction should take place in a TLS channel. +@end itemize + +@end itemize + +@item Data Type: opensmtpd-local-delivery +This data type represents the configuration of an +@code{} 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{} +Deliver the message to an LMTP server at @code{}'s +fieldname @code{destination}. The location may be expressed as string +host:port or as a UNIX socket. Optionally, @code{}'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{} +Deliver the message to the maildir in +@code{}'s fieldname @code{pathname} if specified, +or by default to @code{"~/Maildir"}. + +The pathname may contain format specifiers that are expanded before use +(see the below section about Format Specifiers). + +If @code{}'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{} +Delegate the delivery to the @code{}'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 @code{mapping table} for aliases expansion. + +@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 @code{n@{s|m|h|d@}}. eg: @code{"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{} 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{} record is used for virtual +expansion. +@end itemize + +@item Data Type: opensmtpd-relay +This data type represents the configuration of an +@code{} 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{} 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{} 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 @code{smtp} +@tab Normal SMTP session with opportunistic STARTTLS (the default). +@item @code{smtp+tls} +@tab Normal SMTP session with mandatory STARTTLS@. +@item @code{smtp+notls} +@tab Plain text SMTP session without TLS@. +@item @code{lmtp} +@tab LMTP session. port is required. +@item @code{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 +@code{man table}. It is used with the @code{"smtp+tls"} and @code{"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{} (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{} +Use the alist @code{} 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{} +Use the string or @code{} 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{}. 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}) +If @code{#t}, then execute the command in @code{proc}. +@end itemize + +@item Data Type: opensmtpd-filter-phase +This data type represents the configuration of an +@code{}. + +In a regular workflow, @code{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 +@code{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{} 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 @code{"connect"} +@tab upon connection, before a banner is displayed +@item @code{"helo"} +@tab after HELO command is submitted +@item @code{"ehlo"} +@tab after EHLO command is submitted +@item @code{"mail-from"} +@tab after MAIL FROM command is submitted +@item @code{"rcpt-to"} +@tab after RCPT TO command is submitted +@item @code{"data"} +@tab after DATA command is submitted +@item @code{"commit"} +@tab after message is fully is submitted +@end multitable + +@item @code{options} (default @code{#f}) +A list of unique @code{} records. + +At each phase, various options, specified by a list of +@code{}, may be checked. The +@code{}'s fieldname @code{option} values of: +@code{"fcrdns"}, @code{"rdns"}, and @code{"src"} data are available in +all phases, but other data must have been already submitted before they +are available. Options with a @code{
} next to them require the +@code{}'s fieldname @code{data} to be an +@code{}. There are the available options: + +@multitable {aaaaaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} +@item @code{"fcrdns"} +@tab forward-confirmed reverse DNS is valid +@item @code{"rdns"} +@tab session has a reverse DNS +@item @code{"rdns"}
+@tab session has a reverse DNS in table +@item @code{"src"}
+@tab source address is in table +@item @code{"helo"}
+@tab helo name is in table +@item @code{"auth"} +@tab session is authenticated +@item @code{"auth"}
+@tab session username is in table +@item @code{"mail-from"}
+@tab sender address is in table +@item @code{"rcpt-to"}
+@tab recipient address is in table +@end multitable + +These conditions may all be negated by setting +@code{(opensmtpd-option (bool #f))}. + +Any conditions that require a table may indicate that tables include regexs +setting @code{(opensmtpd-option (regex #t))}. + +@item @code{decision} +A string decision to be taken. Some decisions require an @code{message} +or @code{value}. The value and message may be put in the +@code{}'s fieldname @code{data}. Valid strings are: + +@multitable {aaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} +@item @code{"bypass"} +@tab the session or transaction bypasses filters +@item @code{"disconnect"} message +@tab the session is disconnected with message +@item @code{"junk"} +@tab the session or transaction is junked, +@item +@tab i.e., an ‘X-Spam: yes’ header is added to +@item +@tab any messages +@item @code{"reject"} message +@tab the command is rejected with message +@item @code{"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{}, which is used by +@code{} and @code{} +to match various options for email. + +@itemize +@item @code{option} (default @code{#f}) string + +A string option to be taken. Some options require the fieldname +@code{data} to have a string or an @code{}. When the +option record is used inside of an @code{}, then +valid strings for fieldname @code{option} are: + +@itemize +@item @code {"fcrdns"} +@item @code {"rdns"} +@item @code {"src"} +@item @code {"helo"} +@item @code {"auth"} +@item @code {"mail-from"} +@item @code {"rcpt-to"} +@end itemize + +When @code{} is used inside of an +@code{}, then valid strings for fieldname @code{option} +are: + +@itemize +@item @code {"for"} +@item @code {"for any"} +@item @code {"for local"} +@item @code {"for domain"} +@item @code {"for rcpt-to"} +@item @code {"from any"} +@item @code {"from auth"} +@item @code {"from local"} +@item @code {"from mail-from"} +@item @code {"from rdns"} +@item @code {"from socket"} +@item @code {"from src"} +@item @code {"auth"} +@item @code {"helo"} +@item @code {"mail-from"} +@item @code {"rcpt-to"} +@item @code {"tag"} +@item @code {"tls"} +@end itemize + +@item @code{data} (default @code{#f}) string | @code{} +Some options require a string or @code{} 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 regular +expressions by setting this option to @code{#t}. + +@item @code{bool} (default: @code{#t}) boolean +When @code{(bool #f)}, this option record is negated. +@end itemize + +@item Data Type: opensmtpd-table +This data type represents the configuration of an +@code{}. + +@itemize +@item @code{name} (default @code{#f}) +@code{name} is the name of the @code{} record. + +@item @code{data} (default: @code{#f}) string | list | alist | nested-list +@code{data} expects a string, a list of strings, an alist of strings, or +a nested list of strings. +eg: + +@itemize + +@item string +@lisp +(data "dev@@gnu.org") +@end lisp + +A table of this type is called a @code{string table}. + +@item list +@lisp +(data (list ("gnu.org" "fsf.org"))) +@end lisp + +A table of this type is called a @code{list table}. + +@item alist +@lisp +(data '(("james" . "$encryptedPassword") + ("jennifer" . "$encryptedPassword2))) +@end lisp + +A table of this type is called a @code{mapping table}. + +@item nested-list +@lisp +(data '(("user1" "root@@gnu.org" "admin@@gnu.org") + ("user2" "james@@guix.gnu.org" "sarah@@fsf.org"))) +@end lisp + +A table of this type is also called a @code{mapping table}. + +@end itemize +@end itemize + +@item Data Type: opensmtpd-pki +This data type represents the configuration of an +@code{}. + +@itemize +@item @code{domain} (default @code{#f}) +@code{domain} is the string name of the @code{} 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 @code{"none"}, @code{"legacy"}, or +@code{"auto"}. For @code{"legacy"}, a fixed key length of 1024 bits is +used, whereas for @code{"auto"}, the key length is determined +automatically. The default is @code{"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 @code{"~/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 +This record lets you delegate the delivery to a command that receives +the message on its standard input. + +@itemize +@item @code{name} +The string name for this MDA command. + +@item @code{command} +The command to that delivers the mail. + +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 (@code{"4d"}). +@end itemize + +@item Data Type: opensmtpd-smtp +Data type representing an @code{} 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 +Use this record to set up the Sender Rewriting Scheme (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{}, @code{}) 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..4175cab375 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -35,6 +35,10 @@ (define-module (gnu services mail) #:use-module (gnu packages admin) #:use-module (gnu packages dav) #:use-module (gnu packages tls) + #:use-module (guix i18n) + #:use-module (guix diagnostics) + #:use-module (guix ui) + #:use-module (guix utils) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix gexp) @@ -58,10 +62,149 @@ (define-module (gnu services mail) mailbox-configuration namespace-configuration + opensmtpd-table + opensmtpd-table? + opensmtpd-table-name + opensmtpd-table-data + + opensmtpd-ca + opensmtpd-ca? + opensmtpd-ca-name + opensmtpd-ca-file + + opensmtpd-pki + opensmtpd-pki? + opensmtpd-pki-domain + opensmtpd-pki-cert + opensmtpd-pki-key + opensmtpd-pki-dhe + + opensmtpd-local-delivery + opensmtpd-local-delivery? + opensmtpd-local-delivery-method + opensmtpd-local-delivery-alias + opensmtpd-local-delivery-ttl + opensmtpd-local-delivery-user + opensmtpd-local-delivery-userbase + opensmtpd-local-delivery-virtual + opensmtpd-local-delivery-wrapper + + opensmtpd-maildir + opensmtpd-maildir? + opensmtpd-maildir-pathname + opensmtpd-maildir-junk + + opensmtpd-mda + opensmtpd-mda-name + opensmtpd-mda-command + + opensmtpd-lmtp + opensmtpd-lmtp-destination + opensmtpd-lmtp-rcpt + + opensmtpd-relay + opensmtpd-relay? + opensmtpd-relay-name + opensmtpd-relay-backup + opensmtpd-relay-backup-mx + opensmtpd-relay-helo + opensmtpd-relay-domain + opensmtpd-relay-host + opensmtpd-relay-pki + opensmtpd-relay-srs + opensmtpd-relay-tls + opensmtpd-relay-auth + opensmtpd-relay-mail-from + opensmtpd-relay-src + + opensmtpd-option + opensmtpd-option? + opensmtpd-option-option + opensmtpd-option-bool + opensmtpd-option-regex + opensmtpd-option-data + + opensmtpd-filter-phase + opensmtpd-filter-phase? + opensmtpd-filter-phase-name + opensmtpd-filter-phase-phase + opensmtpd-filter-phase-options + opensmtpd-filter-phase-decision + opensmtpd-filter-phase-message + opensmtpd-filter-phase-value + + opensmtpd-filter + opensmtpd-filter? + opensmtpd-filter-name + opensmtpd-filter-proc + + opensmtpd-interface + opensmtpd-interface? + opensmtpd-interface-interface + opensmtpd-interface-family + opensmtpd-interface-auth + opensmtpd-interface-auth-optional + opensmtpd-interface-filters + opensmtpd-interface-hostname + opensmtpd-interface-hostnames + opensmtpd-interface-mask-src + opensmtpd-interface-disable-dsn + opensmtpd-interface-pki + opensmtpd-interface-port + opensmtpd-interface-proxy-v2 + opensmtpd-interface-received-auth + opensmtpd-interface-senders + opensmtpd-interface-masquerade + opensmtpd-interface-secure-connection + opensmtpd-interface-tag + + opensmtpd-socket + opensmtpd-socket? + opensmtpd-socket-filters + opensmtpd-socket-mask-src + opensmtpd-socket-tag + + opensmtpd-match + opensmtpd-match? + opensmtpd-match-action + opensmtpd-match-options + + opensmtpd-smtp + opensmtpd-smtp? + opensmtpd-smtp-ciphers + opensmtpd-smtp-limit-max-mails + opensmtpd-smtp-limit-max-rcpt + opensmtpd-smtp-max-message-size + opensmtpd-smtp-sub-addr-delim character + + opensmtpd-srs + opensmtpd-srs? + opensmtpd-srs-key + opensmtpd-srs-backup-key + opensmtpd-srs-ttl-delay + + opensmtpd-queue + opensmtpd-queue? + opensmtpd-queue-compression + opensmtpd-queue-encryption + opensmtpd-queue-ttl-delay + opensmtpd-configuration opensmtpd-configuration? + opensmtpd-package + opensmtpd-config-file + opensmtpd-configuration-bounce + opensmtpd-configuration-cas + opensmtpd-configuration-interfaces + opensmtpd-configuration-socket + opensmtpd-configuration-includes + opensmtpd-configuration-matches + ;;opensmtpd-configuration-mda-wrappers + opensmtpd-configuration-mta-max-deferred + opensmtpd-configuration-srs + opensmtpd-configuration-smtp + opensmtpd-configuration-queue opensmtpd-service-type - %default-opensmtpd-config-file mail-aliases-service-type @@ -1641,22 +1784,2351 @@ (define (generate-dovecot-documentation) (listeners unix-listener-configuration fifo-listener-configuration inet-listener-configuration)) (protocol-configuration ,protocol-configuration-fields)) - 'dovecot-configuration)) + 'dovecot-configuration)) -;;; ;;; OpenSMTPD. ;;; +;;; This next bit of code helps me create my own sanitizer functions. + +;; some fieldnames have a default value of #f, which is ok. They cannot have +;; a value of #t. +;; for example opensmtpd-table-data can be #f, BUT NOT true. +;; my/sanitize procedure tests values to see if they are of the right kind. +;; procedure false? is needed to allow fields like 'values' to be blank, +;; (empty), or #f BUT also have a value like a list of strings. +(define (false? var) + (eq? #f var)) + +;; TODO I have to have this procedure, or I need to change my/sanitize +;; procedure. +(define (my-file-exists? file) + (and (string? file) + (access? file F_OK))) + +;; This procedure takes in a var and a list of procedures. It loops through +;; list of procedures passing in var to each. +;; if one procedure returns #t, the function returns true. Otherwise #f. +;; TODO for fun rewrite this using map +;; If I rewrote it in map, then it may help with sanitizing. +;; eg: I could then potentially easily sanitize vars with lambda procedures. +(define (is-value-right-type? var list-of-procedures record fieldname) + (if (null? list-of-procedures) + #f + (if ((car list-of-procedures) var) + #t + (is-value-right-type? var (cdr list-of-procedures) record + fieldname)))) + +;; converts strings like this: +;; "apple, ham, cherry" -> "apple, ham, or cherry" +;; "pineapple" -> "pinneapple". +;; "cheese, grapefruit, or jam" -> "cheese, grapefruit, or jam" +(define (add-comma-or string) + (define last-comma-location (string-rindex string #\,)) + (if last-comma-location + (if (string-contains string ", or" last-comma-location) + string + (string-replace string ", or" last-comma-location + (+ 1 last-comma-location))) + string)) + + +(define (list-of-procedures->string procedures) + (define string + (let loop ((procedures procedures)) + (if (null? procedures) + "" + (begin + (string-append + (cond ((eq? false? (car procedures)) + "#f, ") + ((eq? boolean? (car procedures)) + "a boolean, ") + ((eq? string? (car procedures)) + "a string, ") + ((eq? integer? (car procedures)) + "an integer, ") + ((eq? list-of-strings? (car procedures)) + "a list of strings, ") + ((eq? assoc-list? (car procedures)) + "an association list of strings, ") + ((eq? nested-list? (car procedures)) + "a nested-list of strings, ") + ((eq? opensmtpd-pki? (car procedures)) + "an record, ") + ((eq? opensmtpd-table? (car procedures)) + "an record, ") + ((eq? list-of-opensmtpd-match? (car procedures)) + "a list of unique records, ") + ((eq? list-of-strings-or-gexps? (car procedures)) + "a list of strings or gexps, ") + ;; TODO can I remove the next two procedures? + ;; tables-data-are-a* ? I think I can. + ((eq? tables-data-are-assoc-list? (car procedures)) + (string-append + "an record whose fieldname 'data' are " + "an assoc-list.\nFor example: (opensmtpd-table " + "(name \"hostnames\") , " + "(data '((\"124.394.23.1\" . \"gnu.org\"))))")) + ((eq? tables-data-are-a-list-of-strings? + (car procedures)) + (string-append + "on record whose fieldname 'data' is " + "a list of strings.\n" + "For example: (opensmtpd-table (name \"domains\") , " + "(data (list \"gnu.org\" \"guix.gnu.org\")))")) + ((eq? my-file-exists? (car procedures)) + "a file, ") + (else "has an incorrect value, ")) + (loop (cdr procedures))))))) + (add-comma-or (string-append (string-drop-right string 2) ".\n"))) + +(define (list-of-strings-or-gexps? list) + (and (list? list) + (cond ((null? list) + #t) + ((or (string? (car list)) + (gexp? (car list)) + (local-file? (car list)) + (file-append? (car list)) + (plain-file? (car list)) + (computed-file? (car list)) + (program-file? (car list))) + (list-of-strings-or-gexps? (cdr list))) + (else #f)))) + +(define (my/sanitize var record fieldname list-of-procedures) + (define try-string + (string-append "Try " (list-of-procedures->string list-of-procedures))) + (if (is-value-right-type? var list-of-procedures record fieldname) + var + (begin + (cond ((string? var) + (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var)) + ((or (number? var) (boolean? var)) + (report-error (G_ "(~a ~a) is invalid.~%") fieldname var) ) + (else + (report-error (G_ "(~a ...) is invalid.~%Value is: ~a~%") + fieldname var))) + (display-hint (G_ try-string)) + (throw 'bad! var)))) + +;;; The Opensmtpd records. + +;; Some example opensmtpd-tables: +;; +;; (opensmtpd-table (name "root accounts") +;; (data '(("joshua" . "root@dismail.de") +;; ("joshua" . "postmaster@dismail.de")))) +;; (opensmtpd-table (name "root accounts") +;; (data (list "mysite.me" "your-site.com"))) +;; TODO: How am I supporting file: or db: tables? +;; Perhaps I should just automatically convert the table to a database table +;; if the data gets large enough. What would be sufficently large enough? +(define-record-type* + opensmtpd-table make-opensmtpd-table + opensmtpd-table? + (name opensmtpd-table-name ;; string + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-table" "name" + (list string?))))) + ;; FIXME Support an aliasing table as described here: + ;; https://man.openbsd.org/table.5 + ;; One may have to use the record file for this. I don't think tables + ;; support a table like this: + ;; table "name" { joshua = joshua@gnucode.me,joshua@gnu-hurd.com, \ + ;; joshua@propernaming.org, root = root@gnucode.me } + ;; If values is an absolute filename, then it will use said filename to + ;; house the table info. filename must be an absolute filename. + (data opensmtpd-table-data + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-table" "data" + (list list-of-strings? assoc-list? + nested-list?)))))) + +(define-record-type* + opensmtpd-ca make-opensmtpd-ca + opensmtpd-ca? + (name opensmtpd-ca-name + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-ca" "name" (list string?))))) + (file opensmtpd-ca-file + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-ca" "file" + (list my-file-exists?)))))) + +(define-record-type* + opensmtpd-pki make-opensmtpd-pki + opensmtpd-pki? + (domain opensmtpd-pki-domain + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-pki" "domain" + (list string?))))) + ;; TODO/FIXME this should probably be a list of files. The opensmtpd + ;; documentation says that you could have a list of files: + ;; + ;; pki pkiname cert certfile + ;; Associate certificate file certfile with host pkiname, and use that file + ;; to prove the identity of the mail server to clients. pkiname is the + ;; server's name, derived from the default hostname or set using either + ;; /gnu/store/2d13sdz76ldq8zgwv4wif0zx7hkr3mh2-opensmtpd-6.8.0p2/etc/mailname + ;; or using the hostname directive. If a fallback certificate or SNI is + ;; wanted, the ‘*’ wildcard may be used as pkiname. + + ;; A certificate chain may be created by appending one or many certificates, + ;; including a Certificate Authority certificate, to certfile. The creation + ;; of certificates is documented in starttls(8). + (cert opensmtpd-pki-cert + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-pki" "cert" + (list my-file-exists?))))) + (key opensmtpd-pki-key + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-pki" "key" + (list my-file-exists?))))) + ; todo sanitize this. valid parameters are "none", "legacy", or "auto". + (dhe opensmtpd-pki-dhe + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-dhe" "dhe" + (list false? string?)))))) + +(define-record-type* + opensmtpd-lmtp 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 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 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 make-opensmtpd-local-delivery + opensmtpd-local-delivery? + (name opensmtpd-local-delivery-name + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-local-delivery" "name" + (list string?))))) + (method opensmtpd-local-delivery-method + (default "mbox") + (sanitize (lambda (var) + (define fieldname "method") + (define options (list "mbox" "expand-only" + "forward-only")) + (define options-plus-records + (append options (list "(opensmtpd-lmtp ...)" + "(opensmtpd-maildir ...)" + "(opensmtpd-mda ...)"))) + (cond ((or (opensmtpd-lmtp? var) + (opensmtpd-maildir? var) + (opensmtpd-mda? var) + (member var options)) + var) + (else + (begin + (report-error (G_ "(~a \"~a\") is invalid.~%") + fieldname var) + (display-hint + (G_ (hint-string + var + options-plus-records + #:fieldname fieldname))) + (throw 'bad! var))))))) + (alias opensmtpd-local-delivery-alias + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-local-delivery" "alias" + (list false? + tables-data-are-assoc-list?))))) + (ttl opensmtpd-local-delivery-ttl + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-local-delivery" "ttl" + (list false? string?))))) + (user opensmtpd-local-delivery-user + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-local-delivery" "user" + (list false? string?))))) + (userbase opensmtpd-local-delivery-userbase + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-local-delivery" "userbase" + (list false? + tables-data-are-assoc-list?))))) + (virtual opensmtpd-local-delivery-virtual + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-local-delivery" "virtual" + (list + false? + tables-data-are-assoc-list?))))) + (wrapper opensmtpd-local-delivery-wrapper + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-local-delivery" "wrapper" + (list false? string?)))))) + +(define-record-type* + opensmtpd-relay make-opensmtpd-relay + opensmtpd-relay? + (name opensmtpd-relay-name + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "name" + (list string?)))) + (default #f)) + (backup opensmtpd-relay-backup ;; boolean + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "backup" + (list boolean?))))) + (backup-mx opensmtpd-relay-backup-mx ;; string mx name + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "backup-mx" + (list false? string?))))) + (helo opensmtpd-relay-helo + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "helo" + (list false? string?)))) + (default #f)) + (helo-src opensmtpd-relay-helo-src + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "helo-src" + (list false? string? + tables-data-are-assoc-list?)))) + (default #f)) + (domain opensmtpd-relay-domain + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "domain" + (list false? opensmtpd-table?)))) + (default #f)) + (host opensmtpd-relay-host + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "host" + (list false? string?)))) + (default #f)) + (pki opensmtpd-relay-pki + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "pki" + (list false? opensmtpd-pki?))))) + (srs opensmtpd-relay-srs + (default #f) + (lambda (var) + (my/sanitize var "opensmtpd-relay" "srs" + (list boolean?)))) + (tls opensmtpd-relay-tls + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "tls" + (list false? string?))))) + ;; the table here looks like: + ;; label1 user:password + ;; label2 user2:password2 + ;; It is documented in the credentials table in man table + (auth opensmtpd-relay-auth + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "auth" + (list false? + tables-data-are-assoc-list?)))) + (default #f)) + (mail-from opensmtpd-relay-mail-from + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-relay" "mail-from" + (list false? string?)))) + (default #f)) + ;; string "127.0.0.1" or "" or "
" + ;; TODO should I do some sanitizing to make sure that the string? + ;; here is actually an IP address or a valid interface? + (src opensmtpd-relay-src + (sanitize + (lambda (var) + (my/sanitize var "opensmtpd-relay" "src" + (list false? string? + tables-data-are-a-list-of-strings?)))) + (default #f))) + +;; this record is used by & +;; +(define-record-type* + opensmtpd-option make-opensmtpd-option + opensmtpd-option? + (option opensmtpd-option-option + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-option" "option" + (list string?))))) + (bool opensmtpd-option-bool + (default #t) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-option" "not" + (list boolean?))))) + (regex opensmtpd-option-regex + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-option" "regex" + (list boolean?))))) + (data opensmtpd-option-data + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-option" "data" + (list false? string? opensmtpd-table?)))))) + +(define-record-type* + opensmtpd-filter-phase make-opensmtpd-filter-phase + opensmtpd-filter-phase? + (name opensmtpd-filter-phase-name ;; string + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-filter-phase" "name" + (list string?))))) + (phase opensmtpd-filter-phase-phase ;; string + (default #f) + (sanitize + (lambda (var) + (define options + (list "connect" "helo" "ehlo" "mail-from" + "rcpt-to" "data" "commit")) + (define fieldname "phase") + (if (and (string? var) + (member var options)) + var + (begin + (report-error + (G_ + "(opensmtpd-filter-phase ... (~a \"~a\")) is invalid.~%") + fieldname var) + (display-hint + (G_ (hint-string var options + #:fieldname fieldname))) + (throw 'bad! var)))))) + (options opensmtpd-filter-phase-options + (default #f) + (sanitize + (lambda (var) + (cond + ((false? var) + (report-error (G_ "")) + (display "(opensmtpd-filter-phase (options #f)) is invalid.\n") + (display-hint + (G_ "Try a list of (opensmtpd-option) records.\n")) + (throw 'bad! #f)) + ((not (list-of-opensmtpd-option? var)) + (report-error (G_ "")) + (display "(opensmtpd-filter-phase (options ...) is invalid.\n") + (display-hint + (G_ "Try a list of (opensmtpd-option) records.\n")) + (throw 'bad! var)) + (else (sanitize-options-for-filter-phase var)))))) + (decision opensmtpd-filter-phase-decision + (default #f) + (sanitize + (lambda (var) + (define options + (list "bypass" "disconnect" + "reject" "rewrite" "junk")) + (define fieldname "decision") + (if (and (string? var) + (member var options)) + var + (begin + (report-error (G_ "(~a \"~a\") is invalid.~%") + fieldname var) + (display-hint (G_ (hint-string var options + #:fieldname fieldname))) + (throw 'bad! var)))))) + (message opensmtpd-filter-phase-message + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-filter-phase" "message" + (list false? string?))))) + (value opensmtpd-filter-phase-value + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-filter-phase" "value" + (list false? number?)))))) + +(define-record-type* + opensmtpd-filter make-opensmtpd-filter + opensmtpd-filter? + (name opensmtpd-filter-name + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-filter" "name" + (list string?))))) + (exec opensmtpd-filter-exec + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-filter" "exec" + (list boolean?))))) + ;; a string like "rspamd" or the command to start it like + ;; "/path/to/rspamd --option=arg --2nd-option=arg2" + ;; OR a list of strings and/or geps. + (proc opensmtpd-filter-proc + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-filter" "proc" + (list string? + list-of-strings-or-gexps?)))))) + +;; There is another type of filter that opensmtpd supports, which is a +;; filter chain. A filter chain is a list of s +;; and/or s. This lets you apply several filters under +;; one filter name. I could have defined a record type for it, but the +;; record would only have had two fields: name and list-of-filters. +;; Why write that as a record? It makes the user of this service harder. +;; Instead, just define it as a list, and if a user wants an interface +;; to make multiple filters, he just appends to the 'filters' fieldname. +;; +;; returns #t if list is a unique list of or +;; +;; returns # otherwise +(define (opensmtpd-filter-chain? %filters) + (and (list-of-unique-filter-or-filter-phase? %filters) + (< 1 (length %filters)))) + +(define-record-type* + opensmtpd-interface make-opensmtpd-interface + opensmtpd-interface? + ;; interface may be an IP address, interface group, or domain name + (interface opensmtpd-interface-interface + (default "lo") + (sanitize (lambda (var) + (my/sanitize var "interface" "interface" + (list string?))))) + (family opensmtpd-interface-family + (default #f) + (sanitize + (lambda (var) + (define options (list "inet4" "inet6")) + (define fieldname "family") + (cond + ((eq? #f var) ;; var == #f + var) + ((and (string? var) + (member var options)) + var) + (else + (begin + (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var) + (display-hint (G_ (hint-string var options + #:fieldname fieldname))) + (throw 'bad! var))))))) + (auth opensmtpd-interface-auth + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "auth" + (list boolean? + tables-data-are-assoc-list?))))) + (auth-optional opensmtpd-interface-auth-optional + (default #f) + (sanitize + (lambda (var) + (my/sanitize var "opensmtpd-interface" "auth-optional" + (list boolean? + tables-data-are-assoc-list?))))) + ;; TODO add a ca entry? + ;; string FIXME/TODO sanitize this to support a gexp. That way way the + ;; includes directive can include my hacky scheme code that I use + ;; for opensmtpd-dkimsign. + (filters opensmtpd-interface-filters + (default #f) + (sanitize (lambda (var) + (sanitize-socket-and-interfaces-filters var)))) + (hostname opensmtpd-interface-hostname + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "hostname" + (list false? string?))))) + (hostnames opensmtpd-interface-hostnames + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "hostnames" + (list + false? + tables-data-are-assoc-list?))))) + (mask-src opensmtpd-interface-mask-src + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "mask-src" + (list boolean?))))) + (disable-dsn opensmtpd-interface-disable-dsn + (default #f)) + (pki opensmtpd-interface-pki + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "pki" + (list false? opensmtpd-pki?))))) + (port opensmtpd-interface-port + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "port" + (list false? integer?))))) + (proxy-v2 opensmtpd-interface-proxy-k2 + (default #f)) + (received-auth opensmtpd-interface-received-auth + (default #f)) + (senders opensmtpd-interface-senders + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "senders" + (list false? + tables-data-are-assoc-list?)))) + (default #f)) + (masquerade opensmtpd-interface-masquerade + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "masquerade" + (list boolean?)))) + (default #f)) + (secure-connection opensmtpd-interface-secure-connection + (default #f) + (sanitize + (lambda (var) + (define options + (list "smtps" "tls" "tls-require" + "tls-require-verify")) + (define fieldname "secure-connection") + (cond ((boolean? var) + var) + ((and (string? var) + (member var options)) + var) + (else + (begin + (report-error + (G_ "(~a \"~a\") is invalid.~%") + fieldname var) + (display-hint + (G_ (hint-string var options + #:fieldname fieldname))) + (throw 'bad! var))))))) + (tag opensmtpd-interface-tag + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "tag" + (list false? string?)))) + (default #f))) + +(define-record-type* + opensmtpd-socket make-opensmtpd-socket + opensmtpd-socket? + ;; false or or list of + (filters opensmtpd-socket-filters + (sanitize (lambda (var) + (sanitize-socket-and-interfaces-filters + var + #:socket-or-interface "socket"))) + (default #f)) + (mask-src opensmtpd-socket-mask-src + (default #f) + (my/sanitize var "opensmtpd-interface" "mask-src" + (list false? boolean?))) + (tag opensmtpd-socket-tag + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-interface" "tag" + (list false? string?)))) + (default #f))) + + +(define-record-type* + opensmtpd-match make-opensmtpd-match + opensmtpd-match? + ;;TODO? Perhaps I should add in a reject fieldname. If reject + ;;is #t, then the match record will be a reject match record. + ;; (opensmtpd-match (reject #t)) vs. (opensmtpd-match (action 'reject)) + ;; To do this, I will also have to 'reject' mutually exclusive. + ;; AND an match with 'reject' can have no action defined. + (action opensmtpd-match-action + (default #f) + (sanitize + (lambda (var) + (define fieldname "action") + (if (or (opensmtpd-relay? var) + (opensmtpd-local-delivery? var) + (eq? (quote reject) var)) + var + (begin + (report-error (G_ "(~a \"~a\") is invalid.~%") + fieldname var) + (display-hint + (G_ "Try an (opensmtpd-relay) record, +(opensmtpd-local-delivery) record, or (quote reject).")) + (throw 'bad! var)))))) + (options opensmtpd-match-options + (default #f) + (sanitize (lambda (var) + (sanitize-options-for-opensmtpd-match var))))) + +(define-record-type* + opensmtpd-smtp make-opensmtpd-smtp + opensmtpd-smtp? + (ciphers opensmtpd-smtp-ciphers + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-smtp" "ciphers" + (list false? string?))))) + (limit-max-mails opensmtpd-smtp-limit-max-mails + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-smtp" + "limit-max-mails" + (list false? integer?))))) + (limit-max-rcpt opensmtpd-smtp-limit-max-rcpt + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-smtp" + "limit-max-rcpt" + (list false? integer?))))) + ;; TODO the user could enter in "zebra" which would break the config. + ;; I should sanitize the string to make sure it looks like "50M". + (max-message-size opensmtpd-smtp-max-message-size + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-smtp" + "max-message-size" + (list false? integer? + string?))))) + ;; FIXME/TODO the sanitize function of sub-addr-delim should accept a + ;; string of length one not string? + (sub-addr-delim opensmtpd-smtp-sub-addr-delim + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-smtp" + "sub-addr-delim" + (list false? integer? string?)))))) + +(define-record-type* + opensmtpd-srs make-opensmtpd-srs + opensmtpd-srs? + (key opensmtpd-srs-key + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-srs" "key" + (list false? boolean? my-file-exists?))))) + (backup-key opensmtpd-srs-backup-key + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-srs" "backup-key" + (list false? integer? + my-file-exists?))))) + ;; TODO the user could set the string to be "zebra", which would break + ;; the config. + (ttl-delay opensmtpd-srs-ttl-delay + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-srs" "ttl-delay" + (list false? string?)))))) + +(define-record-type* + opensmtpd-queue make-opensmtpd-queue + opensmtpd-queue? + (compression opensmtpd-queue-compression + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-queue" "compression" + (list boolean?))))) + (encryption opensmtpd-queue-encryption + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-queue" "encryption" + (list boolean? string? + my-file-exists?))))) + ;; TODO the user could set the string to be "zebra", which would break + ;; the config. + (ttl-delay opensmtpd-queue-ttl-delay + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-queue" "ttl-delay" + (list false? string?)))))) (define-record-type* opensmtpd-configuration 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? + (bounce opensmtpd-configuration-bounce + (default #f) + (sanitize + (lambda (var) + (cond ((false? var) + var) + ((and (list? var) + (>= 4 (length var)) + (<= 1 (length var)) + (list-of-strings? var) + (every (lambda (str) + (and (<= 2 (string-length str)) + ;; last character of str is 's' or 'm' + ;; or 'h' or 'd'. + (member (string-take-right str 1) + (list "s" "m" "h" "d")) + ;; first part of str is an integer. + (integer? + (string->number + (string-take str + (- (string-length str) + 1 )))))) + var)) + var) + (else + ;; FIXME TODO I am getting a warning that says + ;; possibly wrong number of arguments to `G_' + ;; is one of the below lines to blame? + (if (string? var) + (report-error (G_ "(bounce \"~a\") is invalid.\n") var) + (report-error (G_ "(bounce ~a) is invalid.\n") var)) + (display-hint (G_ "Try (bounce (list \"30m\" \"2h\"))\n")) + (throw 'bad! var)))))) + (cas opensmtpd-configuration-cas + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-configuration" "cas" + (list false? list-of-opensmtpd-ca?))))) + + ;; list of many records of type opensmtpd-interface + (interfaces opensmtpd-configuration-interfaces + (default (list (opensmtpd-interface))) + (sanitize + (lambda (var) + ;; This makes sure that no opensmtpd-interface is like this: + ;; (opensmtpd-interface (senders #f) (masquerade #t)), which + ;; is a syntax error. + (define (correct-senders? interface) + (not + (and (not (opensmtpd-interface-senders interface)) + (opensmtpd-interface-masquerade interface)))) + + (define fieldname "interface") + + ;; TODO rework this sanitize bit, so that if someone writes: + ;; (opensmtpd-interface (senders #f) (masquerade #t)), they + ;; get a proper error. + ;; (report-error + ;; (G_ "((senders #f) & (masquerade #t)) is invalid.\n")) + (if (and (list-of-interface? var) + (every correct-senders? var) + (not (contains-duplicate? var))) + var + (begin + (display " fieldname ") + (display "'interface' may be #f or a list of records") + (display "\n of unique .\n") + (throw 'bad! var)))))) + (socket opensmtpd-configuration-socket + (default #f) + (sanitize + (lambda (var) + (define fieldname "socket") + (if (or (opensmtpd-socket? var) + (false? var)) + var + (begin + (report-error (G_ "(~a \"~a\") is invalid.~%") + fieldname var) + (display-hint + (G_ + (string-append "Try an (" + fieldname + " (opensmtpd-socket ...)) .\n"))) + (throw 'bad! var)))))) + ;; list of strings of absolute path names + (includes opensmtpd-configuration-includes + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-configuration" "includes" + (list false? list-of-strings? gexp?))))) + (matches opensmtpd-configuration-matches + (default (list (opensmtpd-match + (action (opensmtpd-local-delivery + (name "local") + (method "mbox"))) + (options (list + (opensmtpd-option + (option "for local"))))) + (opensmtpd-match + (action (opensmtpd-relay + (name "outbound"))) + (options (list + (opensmtpd-option + (option "from local")) + (opensmtpd-option + (option "for any"))))))) + ;; TODO perhaps I should sanitize this function like I sanitized + ;; the 'filters'. For example, you could have two different. + ;; actions, one for local delivery and one for remote, + ;; with the same name. + ;; It might be a bit complicated to do this. + ;; I might just let smtpd figure out if the user made a silly + ;; mistake by having two different actions with the same name. + (sanitize (lambda (var) + var + (my/sanitize var "opensmtpd-configuration" "matches" + (list list-of-opensmtpd-match?))))) + ;; list of many records of type mda-wrapper + ;; TODO/FIXME support using gexps here + ;; eg (list "name" gexp) + ;; TODO what are mda-wrappers for? How do I use this fieldname? + ;; (mda-wrappers opensmtpd-configuration-mda-wrappers + ;; (default #f) + ;; (sanitize (lambda (var) + ;; (my/sanitize var + ;; "opensmtpd-configuration" + ;; "mda-wrappers" + ;; (list false? string?))))) + (mta-max-deferred opensmtpd-configuration-mta-max-deferred + (default 100) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-configuration" + "mta-max-deferred" + (list number?))))) + (queue opensmtpd-configuration-queue + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-configuration" "queue" + (list false? opensmtpd-queue?))))) + (smtp opensmtpd-configuration-smtp + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-configuration" "smtp" + (list false? opensmtpd-smtp?))))) + (srs opensmtpd-configuration-srs + (default #f) + (sanitize (lambda (var) + (my/sanitize var "opensmtpd-configuration" "srs" + (list false? opensmtpd-srs?))))) (setgid-commands? opensmtpd-setgid-commands? (default #t))) +;; this help procedure is used 3 or 4 times by +;; sanitize-options-for-opensmtpd-match +(define* (throw-error-duplicate-option option error-arg + #:key (record-name "match")) + (throw-error error-arg + (list + (string-append "(opensmtpd-" record-name + ") (options ...)) can only have one \n" + "(opensmtpd-option (option \"" option + "\")) record, but more are present. \n")) + #:duplicate-option #t)) + +;; this procedure sanitizes the fieldname opensmtpd-match-options +(define* (sanitize-options-for-opensmtpd-match %options) + (define option-list (list "for any" "for local" "for domain" + "for rcpt-to" "from any" "from auth" + "from local" "from mail-from" "from rdns" + "from socket" "from src" "auth" "helo" + "mail-from" "rcpt-to" "tag" "tls")) + (when (not (list-of-opensmtpd-option? %options)) + (report-error (G_ "")) + (display + (string-append "(opensmtpd-match (options ...)) is a list of unique" + " (opensmtpd-option ...) records.\nIt's value is: ")) + (display %options) + (display "\n") + (throw 'bad! %options)) + + (let loop ((%traversing-options %options) + ;; sanitized-options is an alist that may end of looking + ;; like: + ;; (("for" (opensmtpd-option (option "for any"))) + ;; ("from" (opensmtpd-option (option "from any"))) + ;; ("tag (opensmtpd-option (option "tag") (data "tag"))) + (%sanitized-options '()) + (option-record (if (null? %options) + '() + (car %options))) + (option-string (if (null? %options) + '() + (opensmtpd-option-option + (car %options))))) + + (cond + ((null? %traversing-options) + %options) + ;; error if option-string is invalid option + ((not (member option-string option-list)) + (report-error (G_ "(opensmtpd-match \"~a\")) is invalid.\n") + option-string) + (display-hint (G_ "")) + (display (hint-string option-string option-list #:fieldname "option")) + (throw 'bad! option-string)) + ;; error, if duplicate option + ((assoc-ref %sanitized-options option-string) + (report-error (G_ "")) + (display (string-append "(opensmtpd-match (options ...)) can " + "only have one (opensmtpd-option (option " + "\"" option-string "\")), but more " + " \n are present.\n")) + (display-hint + (format #f (G_ "Try removing one (opensmtpd-option (option \"~a\")).~%") + option-string)) + (throw 'bad! option-record)) + ;; error, if duplicate from or duplicate for option + ((or + (if (and (string=? "for" (substring option-string 0 3)) + (assoc-ref %sanitized-options "for")) + #t + #f) + (if (and (>= (length (string->list option-string)) 4) + (string=? "from" (substring option-string 0 4)) + (assoc-ref %sanitized-options "from")) + #t + #f)) + (throw-error %options + (list "(opensmtpd-match (options ...)) can only have one" + " (option \"for ...\") and one (option \"from ...\")" + "\nBut (option \"" option-string "\") and (option \"" + (opensmtpd-option-option + (if (assoc-ref %sanitized-options "for") + (assoc-ref %sanitized-options "for") + (assoc-ref %sanitized-options "from"))) + "\") are present.\n") + #:hint-strings + (list "Try removing one " + (if (string=? "for" (substring option-string 0 3)) + "(opensmtpd-option (option \"for ...\"))" + "(opensmtpd-option (option \"from ...\"))") + " record.\n"))) + ;; these 3 options must have fieldname data defined. + ((and (member option-string + (list "helo" "mail-from" "rcpt-to")) + (not (opensmtpd-option-data option-record))) + (report-error (G_ "")) + (display (string-append "(option \"" option-string + "\") must have (data ...) of type string or an " + "(opensmtpd-table ...) record.\n")) + (throw 'bad! option-string)) + ;; fieldname data must be a string. + ((and (string=? "tag" option-string) + (not (string? (opensmtpd-option-data option-record)))) + (throw-error option-record + (list "(opensmtpd-match ... (option \"tag\"))" + " must have a 'data' of type string.\n"))) + ((or (string=? "tls" option-string) + (string=? "for" (substring option-string 0 3)) + (string=? "from" (substring option-string 0 4))) + ;; let's test the "for" and "from" options now. + (cond + ;; the options in this list cannot define 'data' or 'regex' + ;; fieldnames. + ((and (member option-string (list "for local" "for any" + "from any" "from local" + "from socket" "tls")) + (or (opensmtpd-option-data option-record) + (opensmtpd-option-regex option-record))) + (report-error (G_ "")) + (display (string-append "When (openmstpd-option (option \"" + option-string "\") ...), " + "then (data ...) and (regex ...) " + "must be #f. \n")) + (throw 'bad! option-record)) + ;; the options in this list must have a data field of type + ;; string or tables-data-are-a-list-of-strings? + ((and (member option-string + (list "for domain" "for rcpt-to" + "from mail-from" "from src")) + (or (false? (opensmtpd-option-data option-record)) + (tables-data-are-assoc-list? + (opensmtpd-option-data option-record)))) + (throw-error option-record + (list "When (openmstpd-option (option \"" + option-string "\") ...) \n" + "then (data ...) must be a string or an \n" + "(opensmtpd-table ....) record whose " + "'data' is a list of strings.\n"))) + (else + (loop (cdr %traversing-options) + (alist-cons + (cond ((string=? "for" (substring option-string 0 3)) + "for") + ((string=? "tls" option-string) + "tls") + (else "from")) + option-record + %sanitized-options) + ;;option-record + (if (null? (cdr %traversing-options)) + '() + (car (cdr %traversing-options))) + ;; option-string + (if (null? (cdr %traversing-options)) + '() + (opensmtpd-option-option + (car (cdr %traversing-options)))))))) + ;; TODO if auth's 'data' is an assoc-list table, then + ;; it IS invalid! + ;; option-string = 'auth' cannot be made invalidly, + ;; do not test for it. + (else + (loop (cdr %traversing-options) + (alist-cons option-string option-record + %sanitized-options) + ;;option-record + (if (null? (cdr %traversing-options)) + '() + (car (cdr %traversing-options))) + ;; option-string + (if (null? (cdr %traversing-options)) + '() + (opensmtpd-option-option + (car (cdr %traversing-options))))))))) + +(define (filter-phase-has-message-and-value? record) + (and (opensmtpd-filter-phase-message record) + (opensmtpd-filter-phase-value record))) + +;; return #t if phase needs a message. Or if the message did not start +;; with a 4xx or 5xx status code. otherwise #f +(define (filter-phase-decision-lacks-proper-message? record) + (define decision (opensmtpd-filter-phase-decision record)) + (if (member decision (list "disconnect" "reject")) + ;; this message needs to be RFC compliant, meaning + ;; that it need to start with 4xx or 5xx status code + (cond ((eq? #f (opensmtpd-filter-phase-message record)) + #t) + ((string? (opensmtpd-filter-phase-message record)) + (let ((number (string->number + (substring + (opensmtpd-filter-phase-message record) 0 3)))) + (if (and (number? number) + (and (< number 600) (> number 399))) + #f + #t)))) + #f)) + +;; 'decision' "rewrite" requires 'value' to be a number. +(define (filter-phase-lacks-proper-value? record) + (define decision (opensmtpd-filter-phase-decision record)) + (if (string=? "rewrite" decision) + (if (and (number? (opensmtpd-filter-phase-value record)) + (eq? #f (opensmtpd-filter-phase-message record))) + #f + #t) + #f)) + +;; 'decision' "junk" or "bypass" cannot have a message or a value. +(define (filter-phase-has-incorrect-junk-or-bypass? record) + (and + (member + (opensmtpd-filter-phase-decision record) + (list "junk" "bypass")) + (or + (opensmtpd-filter-phase-value record) + (opensmtpd-filter-phase-message record)))) + +(define (filter-phase-junks-after-commit? record) + (and (string=? "junk" (opensmtpd-filter-phase-decision record)) + (string=? "commit" (opensmtpd-filter-phase-phase record)))) + +;; returns #t if list is a unique list of or +;; returns # otherwise +;; only opensmtpd-filter-chain? uses this function, and opensmtpd-filter-chain +;; is NEVER actually used. +;; I could possibly remove it. +(define (list-of-unique-filter-or-filter-phase? %filters) + (and (list? %filters) + (not (null? %filters)) + ;; this list is made up of only + ;; or + (every (lambda (filter) + (or (opensmtpd-filter? filter) + (opensmtpd-filter-phase? filter))) + %filters) + ;; each filter-name is unique. + (not (duplicate-filter-name %filters)))) + +(define (filters->list-of-filter-names %filters) + (map (lambda (filter) + (cond ((opensmtpd-filter-phase? filter) + (opensmtpd-filter-phase-name filter)) + (else (opensmtpd-filter-name filter)))) + %filters)) + +(define (duplicate-string-in-list strings) + (define first-string (car strings)) + (cond ((null? (cdr strings)) + #f) + ((any (lambda (element) + (if (string=? element first-string) + element + #f)) + (cdr strings)) + first-string) + (else (duplicate-string-in-list (cdr strings))))) + +(define (duplicate-filter-name %filters) + (define filter-names (filters->list-of-filter-names %filters)) + (duplicate-string-in-list filter-names)) + +;; the sanitize procedures used for sanitizing each and +;; fieldname 'filters'. +;; It primarily sanitizes . The only sanitization it does +;; for s, is no make sure there are no duplicate filter names. + +(define* (sanitize-socket-and-interfaces-filters + %filters + #:key (socket-or-interface "interface")) + + ;; if there are two filters with the same name, store that name here. + (define the-duplicate-filter-name + (if (not %filters) + #f + (duplicate-filter-name %filters))) + + (define %filter-phases + (if (not %filters) + '() + (remove opensmtpd-filter? %filters))) + ;; the order of the first two tests in this cond is important. + ;; (false?) has to be 1st and (duplicate-filter-filter-name) has to be + ;; second. You may optionally re-order the other alternates in the cond. + (cond ((false? %filters) + #f) + (the-duplicate-filter-name + (report-error (G_ "")) + (display (string-append + "(opensmtpd-" socket-or-interface + " (filters ...)) has a duplicate filter name: \"" + the-duplicate-filter-name "\".\n")) + (throw 'bad! %filters)) + (else + (let loop ((%traversing-list %filter-phases) + (fieldname (if (null? %filter-phases) + '() + (opensmtpd-filter-phase-decision + (car %filter-phases))))) + (cond + ((null? %traversing-list) + %filters) + ((opensmtpd-filter? (car %traversing-list)) + (loop (cdr %traversing-list) + (if (null? (cdr %traversing-list)) + '() + (opensmtpd-filter-phase-decision + (car (cdr %traversing-list)))))) + ((filter-phase-has-message-and-value? + (car %traversing-list)) + (report-error (G_ "")) + (display + (string-append "(opensmtpd-filter-phase ...) cannot define " + "fieldnames 'value' \n and 'message'.\n"))) + ((filter-phase-decision-lacks-proper-message? + (car %traversing-list)) + (cond + ((string? fieldname) + (report-error + (G_ "(decision \"~a\") with (message ...) is invalid.~%") + fieldname)) + ((or (integer? fieldname) (boolean? fieldname)) + (report-error + (G_ "(decision ~a) with (message ...) is invalid.~%") + fieldname)) + (else + (report-error + (G_ "(~a ...\") with (message ...) is invalid.~%... is ~a") + fieldname))) + (display-hint + (G_ (string-append "Try (opensmtpd-filter-phase " + "(message \"406 Not acceptable.\") " + "(decision \"" fieldname "\")).\n"))) + (throw 'bad! (car %traversing-list))) + ((filter-phase-lacks-proper-value? (car %traversing-list)) + (begin + (report-error (G_ "")) + (display + (string-append + "(opensmtpd-filter-phase (decision \"rewrite\")" + "\n\t\t(value ...)) must be a number.\n")) + (display-hint (G_ "Try (value 5).")) + (throw 'bad! (car %traversing-list)))) + ((filter-phase-has-incorrect-junk-or-bypass? + (car %traversing-list)) + (begin + (report-error (G_ "")) + (display + (string-append "(opensmtpd-filter-phase (decision \"" + (opensmtpd-filter-phase-decision + (car %traversing-list)) + "\") cannot define (message ...) or " + "(value ...).\n")) + (throw 'bad! (car %traversing-list)))) + ((filter-phase-junks-after-commit? (car %traversing-list)) + (begin + (report-error (G_ "")) + (display + (string-append + "(opensmtpd-filter-phase (decision \"junk\")\n\t\t " + "(phase \"commit\")) is invalid.\n")) + (display-hint + (G_ (string-append "You cannot junk an email during phase " + "\"commit\". Try (phase \"data\").\n"))) + (throw 'bad! (car %traversing-list)))) + (else (loop (cdr %traversing-list) + (if (null? (cdr %traversing-list)) + '() + (opensmtpd-filter-phase-decision + (car (cdr %traversing-list))))))))))) + +(define* (sanitize-options-for-filter-phase %options) + (define option-list + (list "fcrdns" "rdns" "src" "helo" "auth" "mail-from" "rcpt-to")) + (let loop ((%traversing-options %options) + ;; sanitized-options is an alist that may end of looking like: + ;; (("fcrdns" (opensmtpd-option (option "fcrdns"))) + ;; ("auth" (opensmtpd-option (option "auth")))) + (%sanitized-options '()) + (option-record (if (null? %options) + '() + (car %options))) + (option-string (if (null? %options) + '() + (opensmtpd-option-option (car %options))))) + (cond + ((null? %traversing-options) + %options) + ;; error if option-string is invalid option + ((not (member option-string option-list)) + (report-error + (G_ "(opensmtpd-filter-phase (option \"~a\")) is invalid.\n") + option-string) + (display-hint (G_ "")) + (display (hint-string option-string option-list + #:fieldname "option")) + (throw 'bad! option-string)) + + ;; if we see two "rdns" (for example), throw a + ;; "duplicate option" error. + ((assoc-ref %sanitized-options option-string) + (report-error (G_ "")) + (display (string-append "(opensmtpd-filter-phase (options ...)) can " + "only have one\n (opensmtpd-option (option \"" + option-string "\")), but more are present.\n")) + (display-hint + (format #f (G_ "Try removing one (option \"~a\").~%") option-string)) + (throw 'bad! option-record)) + + ;; the next 4 options must have fieldname 'data' defined. + ((and (member option-string + (list "src" "helo" "mail-from" "rcpt-to")) + (not (opensmtpd-table? (opensmtpd-option-data option-record)))) + (report-error (G_ "")) + (display (string-append "(opensmtpd-filter-phase ... " "(option \"" + option-string "\")) must define (data ...).\n")) + (display-hint (G_ "Try defining (data (opensmtpd-table ...).\n")) + (throw 'bad! option-record)) + ;;fcrdns cannot have fieldname data defined + ((and (string=? "fcrdns" option-string) + (opensmtpd-option-data option-record)) + (report-error (G_ "")) + (display (string-append "(opensmtpd-option \"" option-string "\") " + "cannot define (data ...).\n")) + (display-hint (G_ "")) + (display "Try removing (data ...).\n") + (throw 'bad! option-record)) + ;; rdns and auth cannot be made invalidly. + ;; skip testing them. + (else (loop (cdr %traversing-options) + (alist-cons option-string option-record + %sanitized-options) + ;; option-record + (if (null? (cdr %traversing-options)) + '() + (car (cdr %traversing-options))) + ;; option-string + (if (null? (cdr %traversing-options)) + '() + (opensmtpd-option-option + (car (cdr %traversing-options))))))))) + +(define* (throw-error var %strings + #:key + (record-name #f) + (duplicate-option #f) + (fieldname #f) + (hint-strings #f)) + (cond ((and record-name fieldname) + (cond ((or (string? var)) + (report-error (G_ "(~a \"~a\") is invalid.~%") fieldname var)) + ((boolean? var) + (report-error (G_ "(~a ~a) is invalid.~%") fieldname var)) + ((number? var) + (report-error (G_ "(~a ~a) is invalid.~%") fieldname + (number->string var))) + (else + (report-error (G_ "(~a ...) is invalid.~%Its value is: ~a~%") + fieldname var))) + (display-hint (G_ (string-append "(opensmtpd-" record-name + " (fieldname " fieldname "...)) " + (apply string-append %strings)))) + (throw 'bad! var)) + ((list? hint-strings) + (report-error (G_ "")) + (display (apply string-append %strings)) + (display-hint (G_ (apply string-append hint-strings))) + (throw 'bad! var)) + ;; display the output for throw-error-duplicate-option + (duplicate-option + (report-error (G_ "")) + (display (apply string-append %strings)) + (display-hint + (format #f + (G_ "Try removing one (opensmtpd-option \"~a\") option.\n") + var)) + (throw 'bad! var)) + (else + (report-error (G_ "")) + (display (apply string-append %strings)) + (throw 'bad! var)))) + +;; if strings is (list "auth" "for any" "from local") +;; Then this will return "Try \"auth\", \"for any\", or \"from local\". +(define (try-string strings) + (string-append "Try " + (let loop ((strings strings)) + (cond ((= 1 (length strings)) + (string-append + "or \"" (car strings) "\".\n")) + (else + (string-append + "\"" (car strings) "\", " + (loop (cdr strings)))))))) + +;; suppose string is "for anys" +;; and strings is (list "for any" "for local" "for domain") +;; then hint-string will return "Did you mean "for any"?" +(define* (hint-string string strings + #:key (fieldname #f)) + (define str (string-closest string strings)) + (if (not str) + (try-string strings) + (if fieldname + (string-append "Did you mean (" fieldname " \"" + str "\") ?\n") + (string-append "Did you mean \"" str "\" ?\n")))) + +;; this is used for sanitizing fieldname 'options' +(define (contains-duplicate? list) + (if (null? list) + #f + (or + ;; check if (car list) is in (cdr list) + (any (lambda (var) + (equal? var (car list))) + (cdr list)) + ;; check if (cdr list) contains duplicate + (contains-duplicate? (cdr list))))) + +(define* (variable->string var #:key (append "") (postpend " ")) + (let ((var (if (number? var) + (number->string var) + var))) + (if var + (string-append append var postpend) + ""))) + +;;; Various functions to check that lists are of the appropriate type. + +;; given a list and procedure, this tests that each element of list is of type +;; ie: (list-of-type? list string?) tests each list is of type string. +(define (list-of-type? list proc?) + (if (and (list? list) + (not (null? list))) + (let loop ((list list)) + (if (null? list) + #t + (if (proc? (car list)) + (loop (cdr list)) + #f))) + #f)) + +(define (list-of-strings? list) + (list-of-type? list string?)) + +(define (list-of-interface? list) + (list-of-type? list opensmtpd-interface?)) + +(define (list-of-opensmtpd-option? list) + (list-of-type? + list opensmtpd-option?)) + +(define (list-of-opensmtpd-ca? list) + (list-of-type? list opensmtpd-ca?)) + +(define (list-of-opensmtpd-pki? list) + (list-of-type? list opensmtpd-pki?)) + +(define (list-of-opensmtpd-match? list) + (list-of-type? list opensmtpd-match?)) + +(define* (list-of-strings->string list + #:key + (string-delimiter ", ") + (postpend "") + (append "") + (drop-right-number 2)) + (string-drop-right + (string-append (let loop ((list list)) + (if (null? list) + "" + (string-append append (car list) postpend + string-delimiter + (loop (cdr list))))) + append) + drop-right-number)) + +;; TODO I should probably change this to alist, because that's what this is. +(define (assoc-list? assoc-list) + (list-of-type? assoc-list + (lambda (pair) + (and (pair? pair) + (string? (car pair)) + (string? (cdr pair)) + (<= 1 (string-length (car pair))) + (<= 1 (string-length (cdr pair))))))) + +(define (nested-list? list) + (every (lambda (element) + (and + (list-of-strings? element) + (< 1 (length element)))) + list)) + +;; this procedure takes in one argument. +;; if that argument is an whose fieldname 'values' is +;; an assoc-list, then it returns #t, #f if otherwise. +(define (tables-data-are-assoc-list? table) + (if (not (opensmtpd-table? table)) + #f + (assoc-list? (opensmtpd-table-data table)))) + +;; this procedure takes in one argument +;; if that argument is an whose fieldname 'values' is a +;; list of strings, then it returns #t, #f if otherwise. +(define (tables-data-are-a-list-of-strings? table) + (if (not (opensmtpd-table? table)) + #f + (and (list-of-strings? (opensmtpd-table-data table))))) + +;; This procedures takes in an +;; if that table a list of lists of strings eg: +;; (list (list "cat") (list "dog")) +;; then this returns #t, otherwise false. +(define (tables-data-are-a-nested-list-of-strings? table) + (cond ((false? (opensmtpd-table-data table)) + #f) + ((not (list? (opensmtpd-table-data table))) + #f) + (else + (nested-list? (opensmtpd-table-data table))))) + +;;; The following functions convert various records into strings. + +;; these next few functions help me to turn
s +;; into strings suitable to fit into "opensmtpd.conf". +(define (assoc-list->string assoc-list) + (string-drop-right + (let loop ((assoc-list assoc-list)) + (if (null? assoc-list) + "" + ;; pair is (cons "hello" "world") -> ("hello" . "world") + (let ((pair (car assoc-list))) + (string-append + "\"" (car pair) "\"" + " = " + "\"" (cdr pair) "\"" + ", " + (loop (cdr assoc-list)))))) + 2)) + +;; can be of type: (quote list-of-strings) or (quote assoc-list) +;; this will output a string that looks like: +;; table <"mytable"> { "ludo"="ludo@gnu.org" } +(define (opensmtpd-table->string table) + (string-append "table \"" (opensmtpd-table-name table) "\" " + (cond ((tables-data-are-a-list-of-strings? table) + (string-append "{ " + (list-of-strings->string + (opensmtpd-table-data table) + #:append "\"" + #:drop-right-number 3 + #:postpend "\"") " }")) + ((tables-data-are-assoc-list? table) + (string-append "{ " + (assoc-list->string + (opensmtpd-table-data table)) " }")) + (else (throw 'youMessedUp table))) + " \n")) + +;; will output something like: +;; <"mytable"> +(define (opensmtpd-table-name->string table) + (string-append "<\"" (opensmtpd-table-name table) "\">")) + +(define (opensmtpd-interface->string record) + (string-append + "listen on " + (opensmtpd-interface-interface record) " " + (let* ((hostname (opensmtpd-interface-hostname record)) + (hostnames (if (opensmtpd-interface-hostnames record) + (opensmtpd-table-name + (opensmtpd-interface-hostnames record)) + #f)) + (filters (opensmtpd-interface-filters record)) + (filter-name (if filters + (if (< 1 (length filters)) + (generate-filter-chain-name filters) + (if (opensmtpd-filter? (car filters)) + (opensmtpd-filter-name (car filters)) + (opensmtpd-filter-phase-name + (car filters)))) + #f)) + (mask-src (opensmtpd-interface-mask-src record)) + (tag (opensmtpd-interface-tag record)) + (senders (opensmtpd-interface-senders record)) + (masquerade (opensmtpd-interface-masquerade record)) + (secure-connection (opensmtpd-interface-secure-connection record)) + (port (opensmtpd-interface-port record)) + (pki (opensmtpd-interface-pki record)) + (auth (opensmtpd-interface-auth record)) + (auth-optional (opensmtpd-interface-auth-optional record))) + (string-append + (if mask-src + (string-append "mask-src ") + "") + (variable->string hostname #:append "hostname ") + (variable->string hostnames #:append "hostnames <" #:postpend "> ") + (variable->string filter-name #:append "filter \"" #:postpend "\" ") + (variable->string tag #:append "tag \"" #:postpend "\" ") + (if secure-connection + (cond ((string=? "smtps" secure-connection) + "smtps ") + ((string=? "tls" secure-connection) + "tls ") + ((string=? "tls-require" secure-connection) + "tls-require ") + ((string=? "tls-require-verify" secure-connection) + "tls-require verify ")) + "") + (if senders + (string-append "senders <\"" (opensmtpd-table-name senders) "\"> " + (if masquerade + "masquerade " + "")) + "") + (variable->string port #:append "port " #:postpend " ") + (if pki + (variable->string (opensmtpd-pki-domain pki) #:append "pki ") + "") + (if auth + (string-append "auth " + (if (opensmtpd-table? auth) + (string-append + (opensmtpd-table-name->string auth)) + "")) + "") + (if auth-optional + (string-append "auth-optional " + (if (opensmtpd-table? auth-optional) + (string-append + "<\"" + (opensmtpd-table-name->string auth-optional) + "\">") + "")) + "") + "\n")))) + +(define (opensmtpd-socket->string record) + (string-append + "listen on socket " + (let* ((filters (opensmtpd-socket-filters record)) + (filter-name (if filters + (if (< 1 (length filters)) + (generate-filter-chain-name filters) + (if (opensmtpd-filter? (car filters)) + (opensmtpd-filter-name (car filters)) + (opensmtpd-filter-phase-name + (car filters)))) + #f)) + (mask-src (opensmtpd-socket-mask-src record)) + (tag (opensmtpd-socket-tag record))) + (string-append + (if mask-src + (string-append "mask-src ") + "") + (variable->string filter-name #:append "filter \"" #:postpend "\" ") + (variable->string tag #:append "tag \"" #:postpend "\" ") + "\n")))) + +(define (opensmtpd-relay->string record) + (let ((backup (opensmtpd-relay-backup record)) + (backup-mx (opensmtpd-relay-backup-mx record)) + (helo (opensmtpd-relay-helo record)) + ;; helo-src can either be a string IP address or an + (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 + (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 into strings. +(define* (opensmtpd-option->string record + #:key + (space-after-! #f)) + (let ((bool (opensmtpd-option-bool record)) + (option (opensmtpd-option-option record)) + (regex (opensmtpd-option-regex record)) + (data (opensmtpd-option-data record))) + (string-append + (if (false? bool) + (if space-after-! + "! " + "!") + "") + option " " + (if regex + "regex " + "") + (if data + (if (opensmtpd-table? data) + (string-append + (opensmtpd-table-name->string data) " ") + (string-append data " ")) + "")))) + +(define (opensmtpd-match->string record) + (string-append "match " + (let* ((action (opensmtpd-match-action record)) + (name (cond ((opensmtpd-relay? action) + (opensmtpd-relay-name action)) + ((opensmtpd-local-delivery? action) + (opensmtpd-local-delivery-name action)) + (else 'reject))) + (options (opensmtpd-match-options record))) + (string-append + (if options + (apply string-append + (map opensmtpd-option->string options)) + "") + (if (string? name) + (string-append "action " "\"" name "\" ") + "reject ") + "\n")))) + +(define (opensmtpd-ca->string record) + (string-append "ca " (opensmtpd-ca-name record) " " + "cert \"" (opensmtpd-ca-file record) "\"\n")) + +(define (opensmtpd-pki->string record) + (let ((domain (opensmtpd-pki-domain record)) + (cert (opensmtpd-pki-cert record)) + (key (opensmtpd-pki-key record)) + (dhe (opensmtpd-pki-dhe record))) + (string-append "pki " domain " " "cert \"" cert "\" \n" + "pki " domain " " "key \"" key "\" \n" + (if dhe + (string-append + "pki " domain " " "dhe " dhe "\n") + "")))) + +(define (generate-filter-chain-name list-of-filters) + (string-drop-right (apply string-append + (flatten + (map (lambda (filter) + (list + (if (opensmtpd-filter? filter) + (opensmtpd-filter-name filter) + (opensmtpd-filter-phase-name filter)) + "-")) + list-of-filters))) + 1)) + +(define (opensmtpd-filter->list-of-strings-and-gexps record) + (list "filter " + "\"" (opensmtpd-filter-name record) "\" " + (if (opensmtpd-filter-exec record) + "proc-exec " + "proc ") + "\"" (opensmtpd-filter-proc record) "\"" + "\n\n")) + +;; this procedure takes in a list of and +;; . It returns a string of the form: +;; filter "uniqueName" chain chain { "filter-name", "filter-name2" [, ...]} +(define (opensmtpd-filter-chain->string list-of-filters) + (string-append "filter \"" + (generate-filter-chain-name list-of-filters) + "\" " + "chain {" + (string-drop-right + (apply string-append + (flatten + (map (lambda (filter) + (list + "\"" + (if (opensmtpd-filter? filter) + (opensmtpd-filter-name filter) + (opensmtpd-filter-phase-name filter)) + "\", ")) + list-of-filters))) + 2) + "}\n\n")) + +(define (opensmtpd-filter-phase->string record) + (let ((name (opensmtpd-filter-phase-name record)) + (phase (opensmtpd-filter-phase-phase record)) + (decision (opensmtpd-filter-phase-decision record)) + (options (opensmtpd-filter-phase-options record)) + (message (opensmtpd-filter-phase-message record)) + (value (opensmtpd-filter-phase-value record))) + (string-append "filter " + "\"" name "\" " + "phase " phase " " + "match " + (apply string-append ; turn the options into a string + (flatten + (map (lambda (option) + (opensmtpd-option->string + option #:space-after-! #f)) + options))) + " " + decision " " + (if (member decision (list "reject" "disconnect")) + (string-append "\"" message "\"") + "") + (if (string=? "rewrite" decision) + (string-append "rewrite " (number->string value)) + "") + "\n\n"))) + +;; in the next procedure, the variable 'filters' is a list of +;; , , and filter chains, which are +;; lists that look like: +;; (list (opensmtpd-filter ...) (opensmtpd-filter-phase ...) +;; (opensmtpd-filter-phase ...) (opensmtpd-filter ...)) +;; This function converts (get-opensmtpd-filters ) +;; to a string. +;; Consider if a user passed in a valid , +;; so that (get-opensmtpd-filters (opensmtpd-configuration)) returns +;; (list (opensmtpd-filter +;; (name "rspamd") +;; (proc "rspamd")) +;; ;; this is a listen-on, with a filter-chain. +;; (list (opensmtpd-filter-phase +;; (name "dkimsign") +;; ...) +;; (opensmtpd-filter +;; (name "rspamd") +;; (proc "rspamd")))) +;; +;; (we will call the above list "total filters"): +;; did you notice that filter "rspamd" is listed twice? Once by itself, and +;; once again in a filter chain. How do you make sure that it is NOT printed +;; twice in smtpd.conf? +;; 1st flatten "total filters", then remove its duplicates so that we +;; may print the s and s. +;; 2nd now we go through "total filters", and we only print the filter-chains. +(define (opensmtpd-filters->list-of-strings-and-gexps filters) + ;; first print the unique s and s. + ;; then print the filter-chains. + ;; to do this: flatten filters, then remove duplicates. + (flatten + (list + ;; TODO for funsies, try to figure out how to list the filter-phases and + ;; filters in one go. I tried it earlier, and it broke the service. + ;; Why? + ;; + + ;; print the filter-phases + (apply string-append + (map (lambda (filter) + (cond ((opensmtpd-filter-phase? filter) + (opensmtpd-filter-phase->string filter)) + (else ""))) + (delete-duplicates (flatten filters)))) + + ;; list the filters that may be gexps + (map (lambda (filter) + (cond ((opensmtpd-filter? filter) + (opensmtpd-filter->list-of-strings-and-gexps filter)) + (else ""))) + (delete-duplicates (flatten filters))) + + ;; now we have to print the filter chains. + (apply string-append + (map (lambda (filter) + (cond ((list? filter) + (opensmtpd-filter-chain->string filter)) + (else ; you are a + ""))) + filters))))) + +(define (opensmtpd-configuration-includes->string string) + (string-append + "include \"" string "\"\n")) + +(define (opensmtpd-configuration-srs->string record) + (let ((key (opensmtpd-srs-key record)) + (backup-key (opensmtpd-srs-backup-key record)) + (ttl-delay (opensmtpd-srs-ttl-delay record))) + (string-append + (variable->string key #:append "srs key " #:postpend "\n") + (variable->string backup-key #:append "srs key backup " #:postpend "\n") + (variable->string ttl-delay #:append "srs ttl " #:postpend "\n") + "\n"))) + +;; TODO make sure all options here work! I just fixed limit-max-rcpt! +(define (opensmtpd-smtp->string record) + (let ((ciphers (opensmtpd-smtp-ciphers record)) + (limit-max-mails (opensmtpd-smtp-limit-max-mails record)) + (limit-max-rcpt (opensmtpd-smtp-limit-max-rcpt record)) + (max-message-size (opensmtpd-smtp-max-message-size record)) + (sub-addr-delim (opensmtpd-smtp-sub-addr-delim record))) + (string-append + (variable->string ciphers #:append "smtp ciphers " #:postpend "\n") + (variable->string limit-max-mails + #:append "smtp limit max-mails " #:postpend "\n") + (variable->string limit-max-rcpt + #:append "smtp limit max-rcpt " #:postpend "\n") + (variable->string max-message-size + #:append "smtp max-message-size " #:postpend "\n") + (variable->string sub-addr-delim + #:append "smtp sub-addr-delim " #:postpend "\n") + "\n"))) + +(define (opensmtpd-configuration-queue->string record) + (let ((compression (opensmtpd-queue-compression record)) + (encryption (opensmtpd-queue-encryption record)) + (ttl-delay (opensmtpd-queue-ttl-delay record))) + (string-append + (if compression + "queue compression\n" + "") + (if encryption + (string-append + "queue encryption " + (if (not (boolean? encryption)) + encryption + "") + "\n") + "") + (if ttl-delay + (string-append "queue ttl" ttl-delay "\n") + "")))) + +;; build a list of from +;; opensmtpd-configuration-matches, which is a list of . +;; Each has a fieldname 'action', which accepts +;; an . +(define (get-opensmtpd-actions record) + (define opensmtpd-actions + (let loop ((list (opensmtpd-configuration-matches record))) + (if (null? list) + '() + (cons (opensmtpd-match-action (car list)) + (loop (cdr list)))))) + (delete-duplicates (append opensmtpd-actions))) + +;; build a list of opensmtpd-pkis from +;; opensmtpd-configuration-interfaces and +;; get-opensmtpd-actions +(define (get-opensmtpd-pkis record) + ;; TODO/FIXME/maybe/wishlist could get-opensmtpd-actions -> NOT have an + ;; opensmtpd-relay? + ;; I think so. And if it did NOT have a relay configuration, then + ;; action-pkis would be '() when it needs to be #f. because if the + ;; opensmtpd-configuration has NO pkis, then this function will + ;; return '(), when it should return #f. If it returns '(), then + ;; opensmtpd-configuration-fieldname->string will + ;; print the string "\n" instead of "" + (define action-pkis + (let loop1 ((list (get-opensmtpd-actions record))) + (if (null? list) + '() + (if (and (opensmtpd-relay? (car list)) + (opensmtpd-relay-pki (car list))) + (cons (opensmtpd-relay-pki (car list)) + (loop1 (cdr list))) + (loop1 (cdr list)))))) + ;; FIXME/TODO/maybe/wishlist + ;; this could be #f aka left blank. aka there are no interface records + ;; with pkis. aka there are no lines in the configuration like: + ;; listen on eth0 tls pki smtp.gnucode.me + ;; in that case the smtpd.conf will have an extra "\n" + (define listen-on-pkis + (let loop2 ((list (opensmtpd-configuration-interfaces record))) + (if (null? list) + '() + (if (opensmtpd-interface-pki (car list)) + (cons (opensmtpd-interface-pki (car list)) + (loop2 (cdr list))) + (loop2 (cdr list)))))) + (delete-duplicates (append action-pkis listen-on-pkis))) + +;; takes in a and returns a list whose +;; elements are , , +;; and a filter-chain. +;; It returns a list of and/or +;; here's an example of what this procedure might return: +;; (list (opensmtpd-filter...) (opensmtpd-filter-phase ...) +;; (openmstpd-filter ...) (opensmtpd-filter-phase ...) +;; ;; this next list is a filter-chain. +;; (list (opensmtpd-filter-phase ...) (opensmtpd-filter...))) +;; +;; This procedure handles filter chains a little odd. +(define (get-opensmtpd-filters record) + (define socket-filters + (if (and (opensmtpd-configuration-socket record) + (opensmtpd-socket-filters + (opensmtpd-configuration-socket record))) + (opensmtpd-socket-filters (opensmtpd-configuration-socket record)) + '())) + (define list-of-interfaces + (if (opensmtpd-configuration-interfaces record) + (opensmtpd-configuration-interfaces record) + '())) + + (delete-duplicates + (append + (remove boolean? + (map-in-order + ;; get the filters found in the s + (lambda (interface-or-socket-record) + (if (and + (opensmtpd-interface-filters interface-or-socket-record) + (= 1 (length (opensmtpd-interface-filters + interface-or-socket-record)))) + ;; this next line returns an + (car (opensmtpd-interface-filters + interface-or-socket-record)) + ;; this next line returns a filter chain. + (opensmtpd-interface-filters interface-or-socket-record))) + list-of-interfaces)) + socket-filters))) + +(define (flatten . lst) + "Return a list that recursively concatenates all sub-lists of LST." + (define (flatten1 head out) + (if (list? head) + (fold-right flatten1 out head) + (cons head out))) + (fold-right flatten1 '() lst)) + +;; This function takes in a record, or list, or anything, and returns +;; a list of s assuming the thing you passed into it had +;; any s. +;; +;; is object record? call func on it's fieldnames +;; is object list? loop through it's fieldnames calling func on it's records +;; is object #f or string? or '()? -> #f +(define (get-opensmtpd-tables value) + (delete-duplicates + (remove boolean? + (flatten ;; turn (list '(1) '(2 '(3))) -> '(1 2 3) + (cond ((opensmtpd-table? value) + value) + ((record? value) + (let* ((record-type (record-type-descriptor value)) + (list-of-record-fieldnames + (record-type-fields record-type))) + (map (lambda (fieldname) + (get-opensmtpd-tables + ((record-accessor record-type fieldname) + value))) + list-of-record-fieldnames))) + ((and (list? value) (not (null? value))) + (map get-opensmtpd-tables value)) + (else #f)))))) + +(define (opensmtpd-configuration-fieldname->string + record fieldname-accessor record->string) + (if (fieldname-accessor record) + (begin + (string-append + (list-of-records->string (fieldname-accessor record) + record->string) "\n")) + "")) + +(define (list-of-records->string list-of-records record->string) + (string-append + (cond ((not (list? list-of-records)) + (record->string list-of-records)) + (else + (let loop ((list list-of-records)) + (if (null? list) + "" + (string-append + (record->string (car list)) + (loop (cdr list))))))))) + +(define (opensmtpd-configuration->string record) + ;; should I use this named let, or should I give this a name, or + ;; not use it at all... + ;; eg: + ;; (write-all-fieldnames + ;; (list (cons fieldname fieldname->string) + ;; (cons fieldname2 fieldname->string))) + ;; (let loop ([list + ;; (list + ;; (cons opensmtpd-configuration-includes + ;; (lambda (string) + ;; (string-append + ;; "include \"" string "\"\n"))) + ;; (cons opensmtpd-configuration-smtp opensmtpd-smtp->string) + ;; (cons opensmtpd-configuration-srs opensmtpd-srs->string))]) + ;; (if (null? list) + ;; "" + ;; (string-append + ;; (opensmtpd-configuration-fieldname->string record + ;; (caar list) + ;; (cdar list)) + ;; (loop (cdr list))))) + (string-append + (opensmtpd-configuration-fieldname->string + record opensmtpd-configuration-bounce + (lambda (%bounce) + (if %bounce + (list-of-strings->string %bounce) + ""))) + (opensmtpd-configuration-fieldname->string record + opensmtpd-configuration-smtp + opensmtpd-smtp->string) + (opensmtpd-configuration-fieldname->string + record + opensmtpd-configuration-srs + opensmtpd-configuration-srs->string) + (opensmtpd-configuration-fieldname->string + record + opensmtpd-configuration-queue + opensmtpd-configuration-queue->string) + ;; write out the mta-max-deferred + (opensmtpd-configuration-fieldname->string + record opensmtpd-configuration-mta-max-deferred + (lambda (var) + (string-append "mta max-deferred " + (number->string + (opensmtpd-configuration-mta-max-deferred record)) + "\n"))) + ;;write out all the tables + (opensmtpd-configuration-fieldname->string record get-opensmtpd-tables + opensmtpd-table->string) + ;; write out all the cas + (opensmtpd-configuration-fieldname->string record + opensmtpd-configuration-cas + opensmtpd-ca->string) + ;; write out all the pkis + (opensmtpd-configuration-fieldname->string record get-opensmtpd-pkis + opensmtpd-pki->string) + ;; write all of the interface and socket records + (opensmtpd-configuration-fieldname->string + record + opensmtpd-configuration-interfaces + opensmtpd-interface->string) + (opensmtpd-configuration-fieldname->string record + opensmtpd-configuration-socket + opensmtpd-socket->string) + ;; write all the actions + (opensmtpd-configuration-fieldname->string record get-opensmtpd-actions + opensmtpd-action->string) + ;; write all of the matches + (opensmtpd-configuration-fieldname->string record + opensmtpd-configuration-matches + opensmtpd-match->string))) + +;; FIXME/TODO should I use format here srfi-28 ? +;; web.scm nginx does a (format #f "string" "another string") +;; this could be a list like +;; (list +;; (file-append opensmtpd-dkimsign "/libexec/filter") +;; "-d gnucode.me -s /path/to/selector.cert") +;; Then opensmtpd-configuration->mixed-text-file could be rewritten to be +;; something like +;; (mixed-text-file +;; (eval `(string-append (opensmtpd-configuration-fieldname->string ...)) +;; (gnu services mail))) +(define (opensmtpd-configuration->mixed-text-file record) + (apply mixed-text-file "smtpd.conf" + (flatten (list + ;; write out the includes + (opensmtpd-configuration-fieldname->string + record + opensmtpd-configuration-includes + opensmtpd-configuration-includes->string) + ;; TODO should I change the below line of code into these + ;; two lines of code? + ;;(opensmtpd-configuration-fieldname->string + ;; record get-opensmtpd-filters-and-filter-phases + ;; opensmtpd-filter-and-filter-phase->string) + ;;(opensmtpd-configuration-fieldname->string + ;; record get-opensmtpd-filter-chains + ;; opensmtpd-filter-chain->string) + ;; write out all the filters + (opensmtpd-filters->list-of-strings-and-gexps + (get-opensmtpd-filters record)) + (opensmtpd-configuration->string record))))) + (define %default-opensmtpd-config-file (plain-file "smtpd.conf" " listen on lo @@ -1668,18 +4140,37 @@ (define %default-opensmtpd-config-file match from local for any action outbound ")) -(define opensmtpd-shepherd-service - (match-lambda - (($ package config-file) - (list (shepherd-service +(define (opensmtpd-shepherd-service config) + (list (shepherd-service (provision '(smtpd)) (requirement '(loopback)) (documentation "Run the OpenSMTPD daemon.") - (start (let ((smtpd (file-append package "/sbin/smtpd"))) - #~(make-forkexec-constructor - (list #$smtpd "-f" #$config-file) - #:pid-file "/var/run/smtpd.pid"))) - (stop #~(make-kill-destructor))))))) + (start + (let ((smtpd (file-append + (opensmtpd-configuration-package config) + "/sbin/smtpd"))) + #~(make-forkexec-constructor + (list #$smtpd "-f" + (or + #$(opensmtpd-configuration-config-file config) + #$(opensmtpd-configuration->mixed-text-file config))) + #:pid-file "/var/run/smtpd.pid"))) + (stop #~(make-kill-destructor))))) + +;; TODO why does the below NOT work? +;(define (opensmtpd-shepherd-service config) +; (match-lambda +; (($ package config-file) +; (list (shepherd-service +; (provision '(smtpd)) +; (requirement '(loopback)) +; (documentation "Run the OpenSMTPD daemon.") +; (start (let ((smtpd (file-append package "/sbin/smtpd"))) +; #~(make-forkexec-constructor +; (list #$smtpd "-f" (or #$config-file +; #$(opensmtpd-configuration->mixed-text-file config))) +; #:pid-file "/var/run/smtpd.pid"))) +; (stop #~(make-kill-destructor))))))) (define %opensmtpd-accounts (list (user-group @@ -1700,10 +4191,10 @@ (define %opensmtpd-accounts (home-directory "/var/empty") (shell (file-append shadow "/sbin/nologin"))))) -(define opensmtpd-activation - (match-lambda - (($ package config-file) - (let ((smtpd (file-append package "/sbin/smtpd"))) +(define (opensmtpd-activation config) + (let ((smtpd (file-append (opensmtpd-configuration-package config) "/sbin/smtpd")) + (config-file (opensmtpd-configuration-config-file config)) + (configuration (opensmtpd-configuration->mixed-text-file config))) #~(begin (use-modules (guix build utils)) ;; Create mbox and spool directories. @@ -1711,7 +4202,36 @@ (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")) + (system* #$smtpd "-nf" + (or + #$config-file + #$configuration))))) + +;; TODO why does this not work? +;(define (opensmtpd-activation config) +; (match-lambda +; (($ package config-file) +; (let ((smtpd (file-append package "/sbin/smtpd")) +; (configuration (opensmtpd-configuration->mixed-text-file config))) +; #~(begin +; (use-modules (guix build utils)) + ;; Create mbox and spool directories. +; (mkdir-p "/var/mail") +; (mkdir-p "/var/spool/smtpd") +; (chmod "/var/spool/smtpd" #o711) +; (mkdir-p "/var/spool/mail") +; (chmod "/var/spool/mail" #o711) +; (display (string-append "checking syntax of " +; (or +; #$config-file +; #$configuration) +; "\n"))))))) (define %opensmtpd-pam-services (list (unix-pam-service "smtpd"))) diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm index f13751b72f..f9bd96402b 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,718 @@ (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 not 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) + +(define (return-false error arg) + #f) + +(define (test-good-record func) + (catch #t func return-false)) + +(define (run-opensmtpd-record-sanitation-test) + ;;(with-output-to-port (%make-void-port "w") + ;; (lambda () + (test-begin "run-opensmtpd-record-sanitation-test") + + (test-error "(interface (filters ...)) has two filters with the same name." + #t + (let ((dkimsign + (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-interface + (interface "lo") + (filters (list + dkimsign + dkimsign))))) + + ;; duplicate filter names. The filters are different, the fix + ;; is to change one filter's 'name' field. + (test-error "Test cannot have two filters with the same name." + #t + (opensmtpd-interface + (filters (list + (opensmtpd-filter-phase + (name "src") + (phase "connect") + (options + (list + (opensmtpd-option + (option "fcrdns") + (bool #f)))) + (decision "junk")) + (opensmtpd-filter-phase + (name "src") + (phase "helo") + (options + (list + (opensmtpd-option + (option "rdns") + (bool #f)))) + (decision "reject") + (message "433 no rdns.")))))) + + (test-error "(filter (proc ...)) is a list of strings or gexps, NOT numbers." + #t + (opensmtpd-filter + (name "dkimsign") + (proc + (list + (file-append opensmtpd-filter-dkimsign + "/libexec/opensmtpd/filter-dkimsign") + " -d gnucode.me -s 2021-09-22 -c relaxed/relaxed -k " + 5 + "/etc/dkim/private.key " + "user nobody group nogroup")) + (exec #t))) + + (test-error "Test fieldname 'phase' has an wrong phase name." + #t + (opensmtpd-filter-phase + (name "filter") + (phase "wrongString") + (decision "bypass") + (options + (list + (opensmtpd-option + (option "auth")))))) + + (test-error + "(filter-phase (decision \"reject\")) requires a 'message'." + #t + (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")))))) + + (test-error (string-append + "Test fieldname 'decision' " + "w/ value \"reject\" and \"disconnect\" requires a 'message'." + " The message must begin with 4xx or 5xx.") + #t + (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!")))))) + + (test-error + "(filter-phase \"rewrite\") requires fieldname 'value' to have a number." + #t + (opensmtpd-interface + (filters + (list + (opensmtpd-filter-phase + (name "noFRDNS") + (phase "commit") + (options (list (opensmtpd-option + (option "fcrdns") + (bool #f)))) + (decision "rewrite")))))) + + (define option-string1/2 (list-ref (list "junk" "bypass") + (random 2))) + (test-error + (string-append "(filter-phase \"decision\" with values 'junk' or 'bypass'," + " then fieldname 'message' and 'value' must be blank.") + #t + (opensmtpd-interface + (filters + (list + (opensmtpd-filter-phase + (name "noFRDNS") + (phase "commit") + (options (list (opensmtpd-option + (option "fcrdns") + ))) + (decision option-string1/2) + (message "This is not a good email.")))))) + + (test-error "You cannot junk an email on phase commit." + #t + (opensmtpd-interface + (filters + (list + (opensmtpd-filter-phase + (name "junk-after-commit") + (options (list (opensmtpd-option + (option "fcrdns")))) + (phase "commit") + (decision "junk")))))) + + (define (good-interface1) + (opensmtpd-interface + (senders + (opensmtpd-table + (name "senders") + (data '(("joshua" . "joshua@dismail.de"))))) + (masquerade #t))) + + (test-assert "good interface" (test-good-record good-interface1)) + + (test-error "Test has 2 duplicate options." + #t + (opensmtpd-filter-phase + (name "invalid-fcrdns") + (phase "connect") + (options + (list (opensmtpd-option + (option "fcrdns")) + (opensmtpd-option + (option "fcrdns")))) + (decision "reject") + (message "422 No valid fcrdns."))) + + (test-error "Test option 'src' requires a table." + #t + (opensmtpd-filter-phase + (name "filter") + (phase "helo") + (decision "bypass") + (options + (list + (opensmtpd-option + (option "src")))))) + + (test-error "Test option 'fcrdns' cannot have a table." + #t + (opensmtpd-filter-phase + (name "filter") + (phase "helo") + (decision "bypass") + (options + (list + (opensmtpd-option + (option "fcrdns") + (data (opensmtpd-table + (name "table") + (data (list "hello" "cat"))))))))) + + (test-error "Test must have at least one option." + #t + (opensmtpd-filter-phase + (name "filter") + (phase "helo") + (decision "bypass"))) + + (test-error + "(filter-phase (options ...)) must be a list of s." + #t + (opensmtpd-filter-phase + (name "rdns") + (decision "junk") + (phase "helo") + (options + (list 5)))) + + (test-error "Test (decision \"junks\") is invalid." + #t + (opensmtpd-filter-phase + (name "this") + (options (list + (opensmtpd-option + (option "auth")))) + (phase "helo") + (decision "junks"))) + + (test-error + (string-append + "(local-delivery (virtual ...) must be an " + "whose 'data' is an alist.") + #t + (opensmtpd-local-delivery + (name "receive") + (method (opensmtpd-maildir + (pathname "/home/%{rcpt.user}/Maildir"))) + (virtual (opensmtpd-table + (name "virt") + (data (list "jbranso@dismail.de")))))) + + (test-error "(opensmtpd-match (options ...)) should not be quoted." + #t + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options + '((opensmtpd-option + (option "for any")))))) + + (test-error "Test has duplicate 'for' options." + #t + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list + (opensmtpd-option + (option "for any")) + (opensmtpd-option + (option "for local")))))) + + (test-error "Test has duplicate 'from' options." + #t + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list + (opensmtpd-option + (option "from any")) + (opensmtpd-option + (option "from auth")))))) + + (define option-string1 + (list-ref (list "helo" "rcpt-to" "mail-from") + (random 3))) + ;; rcpt-to, mail-from, and helo must have a data field. + (test-error (string-append "Test (opensmtpd-option (option \"" + option-string1 + "\")) must also define fieldname 'data'.") + #t + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list + (opensmtpd-option + (option option-string1)))))) + (define option-string2 + (list-ref (list "for local" "for any" "from any" + "from local" "from socket" "tls") + (random 6))) + ;; "for local" "for any" "from any" "from local" "from socket" "tls" + ;; cannot have data or regex defined + (test-error (string-append "Test (opensmtpd-option (option \"" + option-string2 + "\")) cannot have fieldname 'data' defined.") + #t + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list + (opensmtpd-option + (option option-string2) + (regex #t)))))) + + (test-error "(opensmtpd-match (action ...)) needs to be defined." + #t + (opensmtpd-match + (options (list + (opensmtpd-option + (option "from auth")))))) + + (test-error "(opensmtpd-match (options ...)) has duplicate 'helo's." + #t + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list + (opensmtpd-option + (option "helo") + (bool #f)) + (opensmtpd-option + (option "helo")))))) + + (test-error "(opensmtpd-match (options ...)) has duplicate 'mail-from's." + #t + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list + (opensmtpd-option + (option "mail-from") + (data "hello")) + (opensmtpd-option + (option "mail-from") + (data "world")))))) + + (test-error + "(opensmtpd-match (options ...)) has an invalid option name: fcrdns." + #t + (opensmtpd-match + (options (list + (opensmtpd-option + (option "fcrdns")))) + (action (opensmtpd-relay + (name "relay"))))) + + (test-error + "(opensmtpd-match (options ...)) has an invalid option name: rdns." + #t + (opensmtpd-match + (options (list + (opensmtpd-option + (option "rdns")))) + (action (opensmtpd-relay + (name "relay"))))) + + (test-error + (string-append + "(opensmtpd-match (options ...)) option-name 'tag' must " + "also have 'data' be a string.") + #t + (opensmtpd-match + (options (list + (opensmtpd-option + (option "tag")))) + (action (opensmtpd-relay + (name "relay"))))) + + (define option-string3 + (list-ref (list "for domain" "for rcpt-to" + "from mail-from" "from src") + (random 4))) + ;; the options in this list: + ;; (list "for domain" "for rcpt-to" "from mail-from" "from src") + ;; must have a data field. + (test-error + (string-append "Test (opensmtpd-option (option \"" + option-string3 "\"))" + " must define fieldname 'data'.") + #t + (opensmtpd-match + (options (list + (opensmtpd-option + (option option-string3)))) + (action (opensmtpd-relay + (name "relay"))))) + + (define option-string4 + (list-ref (list "for local" "for any" "from any" + "from local" "from socket" "tls") + (random 6))) + ;; the options in this list cannot have a data or regex field defined. + ;; (list "for local" "for any" "from any" "from local" "from socket" "tls") + (test-error (string-append "Test (opensmtpd-option (option \"" + option-string4 "\"))" + " cannot define fieldname 'data'.") + #t + (opensmtpd-match + (options (list + (opensmtpd-option + (regex #t) + (option option-string4)))) + (action (opensmtpd-relay + (name "relay"))))) + + + (define option-string5 + (list-ref (list "for domain" "for rcpt-to" + "from mail-from" "from src") + (random 4))) + (test-error (string-append "Test (opensmtpd-option (option \"" + option-string5 "\"))" + " must define fieldname 'data' as a string or " + "an , whose 'data' \n" + "is a list of strings.") + #t + (opensmtpd-match + (options + (list (opensmtpd-option + (option option-string5) + (data (opensmtpd-table + (name "src-table") + (data '(("127.0.0.1" . "374.394.405.23")))))))) + (action (opensmtpd-relay + (name "relay"))))) + + ;; match must have at least one option. + (test-error + "(opensmtpd-match (options ...)) must have at least one ." + #t + (opensmtpd-match + (action + (opensmtpd-local-delivery + (name "mail"))))) + + ;; you cannot have strings of length 0. + (test-error + (string-append + "(opensmtpd-table (name \"table\") (data '((\"james\" . \"\")))) " + "has an empty string.") + #t + (opensmtpd-table + (name "mytable") + (data '(("hello" . ""))))) + + (define good-match1 + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list (opensmtpd-option + (option "for any")) + (opensmtpd-option + (option "from any")) + (opensmtpd-option + (option "auth")))))) + + (test-assert "good match" (test-good-record good-match1)) + ;;(test-assert "Test is valid.") + + ;; I used to have some code that assumed if you have + ;; an "" and an "" using the same filter, then that + ;; was a misconfiguration. It's not. + (define (good-opensmtpd-configuration1) + (let ([interface "lo"] + [filter-dkimsign + (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")))]) + (opensmtpd-configuration + (interfaces + (list + ;; send out emails and be sure to dkimsign them. + (opensmtpd-interface + (interface interface) + (filters (list filter-dkimsign))))) + (socket + (opensmtpd-socket + (filters (list filter-dkimsign)))) + (matches (list + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list (opensmtpd-option + (option "for any")) + (opensmtpd-option + (option "from any")) + (opensmtpd-option + (option "auth")))))))))) + + (test-assert + (string-append "opensmtpd-configuration may use the same dkimsign " + "filter on and .") + (test-good-record good-opensmtpd-configuration1)) + + ;; this is just the largest configuration that I can test. + (define (good-opensmtpd-configuration2) + (let ([interface "lo"] + [creds-table + (opensmtpd-table + (name "creds") + (data + (list + (cons "joshua" + "$6$Ec4m8FgKjT2F/03Y$k66ABdse9TzCX6qaALB3WBL9GC1rmAWJmaoSjFMpbhzat7DOpFqpnOwpbZ34wwsQYIK8RQlqwM1I/v6vsRq86."))))] + [receive-action + (opensmtpd-local-delivery + (name "receive") + (method (opensmtpd-maildir + (pathname "/home/%{rcpt.user}/Maildir") + (junk #t))) + (alias (opensmtpd-table + (name "aliases") + (data '(("joshua@gnucode.me" . "joshua"))))) + (virtual (opensmtpd-table + (name "virt") + (data '(("josh" + . "jbranso@dismail.de"))))))] + ;; as of 7-24-22 this proc fieldname does not actually work, but + ;; is proper syntax. + [filter-dkimsign (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")))] + [filter-invalid-fcrdns (opensmtpd-filter-phase + (name "invalid-fcrdns") + (phase "connect") + (options + (list (opensmtpd-option + (option "fcrdns") + (bool #f)))) + (decision "reject") + (message "422 No valid fcrdns."))] + [filter-invalid-rdns (opensmtpd-filter-phase + (name "invalid-rdns") + (phase "connect") + (options + (list (opensmtpd-option + (option "rdns") + (bool #f)))) + (decision "junk"))] + [smtp.gnucode.me (opensmtpd-pki + (domain "smtp.gnucode.me") + (cert "guix.scm") + (key "guix.scm"))]) + (opensmtpd-configuration + (mta-max-deferred 50) + (queue + (opensmtpd-queue + (compression #t))) + (smtp + (opensmtpd-smtp + (max-message-size "10M"))) + (srs + (opensmtpd-srs + (ttl-delay "5d"))) + (interfaces + (list + (opensmtpd-interface + (interface interface) + (port 25) + (secure-connection "tls") + (filters (list filter-invalid-fcrdns + filter-invalid-rdns)) + (pki smtp.gnucode.me)) + ;; this lets local users logged into the system via ssh send email + ;; be sure to dkimsign them. + (opensmtpd-interface + (interface interface) + (port 465) + (secure-connection "smtps") + (pki smtp.gnucode.me) + (auth creds-table) + (filters (list filter-dkimsign))) + ;; if you uncomment this next line, then you get issues. + ;;(opensmtpd-socket + ;; (filters (list filter-dkimsign))) + ;; send out emails and be sure to dkimsign them. + (opensmtpd-interface + (interface interface) + (port 587) + (secure-connection "tls-require") + (pki smtp.gnucode.me) + (auth creds-table) + (filters (list filter-dkimsign))))) + (socket + (opensmtpd-socket + (filters (list filter-dkimsign)) + (tag "socket"))) + (matches (list + (opensmtpd-match + (action (opensmtpd-relay + (name "relay"))) + (options (list (opensmtpd-option + (option "for any")) + (opensmtpd-option + (option "from any")) + (opensmtpd-option + (option "auth"))))) + (opensmtpd-match + (action receive-action) + (options (list (opensmtpd-option + (option "from any")) + (opensmtpd-option + (option "for domain") + (data (opensmtpd-table + (name "domain-table") + (data (list "gnucode.me" + "gnu-hurd.com")))))))) + (opensmtpd-match + (action receive-action) + (options (list (opensmtpd-option + (option "for local")))))))))) + + (test-assert "Test my largish example ." + (test-good-record good-opensmtpd-configuration2)) + + ;; the matches have two actions with the same name, + ;; but are different actions. + (test-error + (string-append "Test fieldname 'matches' has " + "two actions with the same name, but the actions are " + "different.") + #t + (opensmtpd-configuration + (matches + (list (opensmtpd-match + (options + (list + (opensmtpd-option + (option "auth")))) + (action + (opensmtpd-local-delivery + (name "my-local-delivery") + (ttl "50m")))) + (opensmtpd-match + (options + (list + (opensmtpd-option + (option "auth")))) + (action + (opensmtpd-local-delivery + (name "my-local-delivery") + (ttl "50h")))))))) + + ;; you can only have 1 opensmtpd-socket. + (test-error + (string-append + "(opensmtpd-configuration> (listen-on ...)) may only have " + "one .") + #t + (let ([interface "lo"]) + (opensmtpd-configuration + (socket + (list + (opensmtpd-socket) + (opensmtpd-socket))) + (matches (list + (opensmtpd-match + (options + (list + (opensmtpd-option + (option "auth")))) + (action (opensmtpd-relay + (name "relay"))))))))) + + (test-end "run-opensmtpd-record-sanitation-test")) + +(define %test-opensmtpd-record-sanitation + (system-test + (name "opensmtpdRecordSanitation") + (description + (string-append " 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.1