work/0000775000000000000000000000000015116102070006721 5ustar work/.gdbinit0000664000000000000000000000004015116102070010334 0ustar set args ./asynch.tcl sauce.tcl work/.gitignore0000664000000000000000000000212015116102070010704 0ustar adminsecret settings sauceadmin sauce policies readlibs readconf library stall thread dns avf avfpool smtp msgdata notifybl datastate yesmaster convertdb firewall rcpt-policy sconfig sauce-await-startup sauce-bwlist sauce-setsyspolicy sauce-setuserpolicy sauce-userblacklist sauce-firewall sauce-rcptpolicy sauce9-convert fatal.log error.log notice.log dbreasons.log debug.log clean-site-annoy cdb.site-seen.main cdb.site-seen.jrn cdb.site-seen.cdb cdb.site-seen.lock cdb.site-list.main cdb.site-list.jrn cdb.site-list.cdb cdb.site-list.lock cdb.site-annoy.main cdb.site-annoy.jrn cdb.site-annoy.cdb cdb.site-annoy.lock cdb.addr-seen.main cdb.addr-seen.jrn cdb.addr-seen.cdb cdb.addr-seen.lock cdb.addr-list.main cdb.addr-list.jrn cdb.addr-list.cdb cdb.addr-list.lock cdb.addr-annoy.main cdb.addr-annoy.jrn cdb.addr-annoy.cdb cdb.addr-annoy.lock db.addr-seen.main db.addr-seen.log db.addr-list.main db.addr-list.log db.site-annoy.main db.site-annoy.log db.site-seen.main db.site-seen.log db.site-list.main db.site-list.log *.orig debian/files debian/tmp debian/sauce.substvars debian/sauce.*.debhelper work/BLURB.text0000664000000000000000000000560515116102070010503 0ustar SAUCE (Software Against Unsolicited Commercial Email) is an SMTP server that sits between the Internet and your actual mail software. It was originally written to help in the fight against spam, but it also helps encourage good configuration and administration in general. It has various tactics for reducing incoming spam: * Extremely aggressive checks on incoming email and its sources. If any problems are discovered the mail is not accepted. * Spambait addresses: when mail is sent to a bait address its sources are blacklisted. * Mail from previously-unknown sources is delayed to give them a chance to try a bait address or get their account cancelled. Pros: * SAUCE is very sucessful. It can cut spam by an order of magnitude. * Administrators using SAUCE have to deal with much less bounced mail. * SAUCE never bounces legitimate mail from correct, non-spamming sites. Cons: * Hardly any documentation at the moment - for mail experts only ! * Most spam sources are misconfigured, but many other sites are too, and SAUCE will bounce their mail. SAUCE is not for you if clueless strangers often send you mail that's important to you. * SAUCE delays mail from new senders and sites (configurable, though). * SAUCE is something of a resource hog. * SAUCE is hard to install, especially if you're not using Debian. SAUCE is not a mailer. You need existing SMTP software, which must have standard anti-spam features such as relay prevention, checking recipients during the SMTP conversation, etc. Currently you must be using Exim, though support for other mailers could be added. You also need Tcl 8.1 or later. SAUCE is not a message filter. You must run SAUCE on every MX for the relevant mail domain(s) so that it is the first thing to see every mail. Software which will make SAUCE easier to install or more functional: * authbind (as from Debian GNU/Linux). * userv (`you-serve', www.chiark.greenend.org.uk/~ian/userv/). * Linux 2.2 ipchains firewalling. See also: The Exim Internet Mailer (www.exim.org) The Coalition Against Unsolicited Commercial Email (www.cauce.org) This file is part of SAUCE, a very picky anti-spam receiver-SMTP. SAUCE is Copyright (C) 1997-2003 Ian Jackson This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. $Id: BLURB.text,v 1.4 2003/06/15 15:46:40 ian Exp $ work/COPYING0000664000000000000000000004312715116102070007763 0ustar GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. work/ERRORS.text0000664000000000000000000004157115116102070010653 0ustar This file lists the errors issued by SAUCE and what they mean. Note that this manual is still very sketchy, and in many cases only Internet mail and/or DNS experts will be able to understand it. All messages may be followed by [ANGER_LEVEL] This will appear if the sending of the response was delayed due to anger, for all major errors, and always in the greeting. Anger levels: Furious - so angry that further anger won't incur any longer delays to messages Angry - angry enough that even success responses are delayed Irritated - only error responses are delayed Pleased - no delays to any messages (anger is zero or negative) Ecstatic - more than halfway to the maximum pleasure level, and also more pleased than Furious is angry. SMTP read errors are counted as Major. 220 $canonical_hostname sauce-smtpd ESMTP ready 221 $canonical_hostname goodbye Response to QUIT. Connection closes. 250 $canonical_hostname hello $ident@$remote_host (postmaster@$main_domain) Response to HELO. $remote_host is the hostname if it is available. If the calling mail domain name has not been determined the bit in parens it is omitted. $ident is empty if no RFC1413 (`TCP remote username protocol') ident could be acquired. 250-$canonical_hostname hello $ident@$remote_host (postmaster@$main_domain) 250-8BITMIME 250 PIPELINING Response to EHLO. (Exact list of extensions will depend on the underlying MTA.) 250 NOOP OK 250 OK Response to RSET. 354 Send text Normal response to DATA. 504 SAUCESTATE not available. 100- 100-$state_variable $value ... 100 Responses to SAUCESTATE (disabled by default). config allow_saucestate. 214- 214 QUIT HELP NOOP HELO EHLO MAIL RCPT DATA QUIT RSET VRFY Response to HELP. 502 Command unrecognised SAUCE doesn't recognise an SMTP command. This should not happen, since senders should use ESMTP EHLO (RFC1651) to probe for extension commands before trying to use them. Major. 421 $canonical_hostname Shutting down Never delayed, doesn't increase anger. Connection closes. 501 No parameters allowed Could be in response to RST, NOOP, HELP, DATA, QUIT. Major. 500 Syntax error Input was received that didn't look like an SMTP command verb followed by some parameters, where one was expected. This would indicate serious protocol violation problems. Major. 503 need HELO or EHLO before MAIL 503 MAIL already issued 503 HELO or EHLO already specified This would mean that SAUCE and the sender disagree about the state of the SMTP session between them, which is a bug in one or both. See RFC821 s3.1. Major. 501 Syntax error in parameter to MAIL 501 Syntax error in parameter to RCPT 501 Syntax error in recipient ($description) 501 Syntax error in sender ($description) MAIL must be followed by FROM: or by FROM:<> (and either may be followed by additional parameters); RCPT must be followed by TO:. Depending on the address this might be due to weird addresses and/or failure to quote properly by the sending MTA. RFC821 s3.1, s4.1.2; RFC1123 s5.2.9. See also address syntax errors, below. Major. Descriptions of address syntax errors include: invalid domain invalid source route syntax invalid local-part syntax 550 Domain-literal senders not allowed Ie, MAIL FROM:<$user@[$address]>. Major. 250 [$address] $response The MAIL FROM address was verified and is accepted. For example: << MAIL FROM: SAUCE looks up from.example.com using MX and A records and finds that a mail exchanger with address (say) 172.30.206.1 is listed. Then SAUCE connects to it and has the following dialogue: << 220 from.example.com >> MAIL FROM:<> << 250 >> RCPT TO: << 250 is fine by me Then it issues in the original session: >> 250 [172.30.206.1] is fine by me 450 Unable to verify: $verification_temp_failure 550 $verification_perm_failure This happens in response to MAIL FROM if the address verification fails. See below for details of address verification error messages. Major. 503 MAIL FROM parameter string too long One of the optional (extension) parameters to MAIL FROM was too long. config max_smptpparams_size. Major. 252 VRFY not supported by SAUCE. RFC1123 5.2.3. 503 need MAIL before RCPT 503 No recipients specified Usually this means that a sender made use of the PIPELINING SMTP extension (RFC1854), but RCPT failed, so the state machine is wrong for the RCPT or DATA command, respectively; this error is just the response to the next command which was issued before the result of the first one was known. This will not cause these errors to appear in bounces. If they occurs in other contexts the SMTP state machines in SAUCE and the sender are out of step, which is a bug in one or both; see RFC821 s3.1. Minor. Eg: >> 220 to.example.com << EHLO from.example.com >> 250-to.example.com >> 250 PIPELINING << MAIL FROM: << RCPT TO: << DATA >> 550 [172.30.206.1] 550 Unknown user bogus >> 503 need MAIL before RCPT >> 503 No recipients specified 501 Syntax error in HELO domain The argument to HELO or EHLO must have proper hostname syntax. RFC1123 s5.2.5, RFC821 s4.1.2. This commonly occurs if characters like underscores, which are not legal in hostnames, are used in configuration. Major. 504 IP literal ([$addr]) in HELO forbidden by adminstrator By default, SAUCE will reject HELO and/or EHLO which consists of an IP address instead of a domain name. config forbid_helo_ipliteral. Major. 504 HELO name ($name) has no address matching [$address] 504 HELO name ($name) does not map to any addresses: $dns_perm_error 504 HELO name ($name) has no address matching [$address] 450 HELO name ($name) lookup failed: $dns_temp_error HELO/EHLO name checking is enabled (this is not the default), but the name given did not map to a set of set of addresses which include the calling host. config check_helo_name. See DNS errors, below. Major. 393 $chal 501 \x{24} \x{32} please 503 Need SAUCEADMIN on its own first 490 challenge overwritten 491 challenge timed out 495 admin secret missing# 492 incorrect response 294 yes master To do with the SAUCE-specific SAUCEADMIN command. Should not happen to real SMTP clients. Never delayed, 5xx codes are major, others do not induce anger. 504 Cannot find address host name via reverse DNS or HELO The usual algorithm for finding the caller's mail domain name (which will be used, for example, to send blacklist notifications), starts with the HELO domain name, or failing that the reverse DNS domain from the SMTP connection. This domain is looked up for MX records. If none are found then one leaf name is stripped and the lookup is repeated. If no domains with MX records are found before the domain reaches 1 component then the whole original domain name is used. If the HELO string is an IP address literal and the reverse DNS is not correct then this procedure is not possible because there is no starting point. config require_callingmaildomain_name, require_callingmaildomain_dnsok, require_reverse_dns. If the check is disabled an IP literal for the calling system is used where the calling mail domain is required. Major. 450 Cannot find mail domain (MX for $domain): $dns_error During the lookups described above, SAUCE encountered some kind of DNS problem. Major. 250 $bland_message Response to RCPT: the message is being junked due to the caller being blacklisted; recipients are accepted so that data is transferred and the maximum amount of data for the blacklists is acquired. config bland_message. 2xx $mta_response Successful Response to RCPT or message body. The underlying MTA's message is shown. xxx $mta_response Error response to MAIL, RCPT, DATA or message body from underlying MTA. Major. 550 $rbl_message Calling site is blacklisted by RBL configuration. config rbl. Major. 550 Blacklisted sender $local@$domain 550 Blacklisted site [$address] Response to RCPT. Caller is blacklisted. Major. 250 You are on the whitelist Response to MAIL FROM. Calling site and sender address are whitelisted. 250 You are on the blacklist Response to MAIL FROM. Calling sender address is blacklisted; RCPTs will be rejected with `550 Blacklisted sender', above. 250 You were verified previously Response to MAIL FROM. The sender address was verified at some point in the past. 250 You are on the greylist Response to MAIL FROM. The calling site or sender address were first encountered recently and were OK then, but are still on probation. 250 Bounce is from whitelisted site 250 Ready to receive a bounce Responses to MAIL FROM:<>. 421 $canonical_hostname $address: reverse DNS: $dns_error On connection. config require_reverse_dns. Major. Connection closes. 421 $canonical_hostname $any_response [too many errors] Too many errors occurred on the same SMTP connection. $any_response is the error response that was about to be issued but which broke the camel's back. Major. Connection closes. 421 $canonical_hostname Timed out waiting for command Minor. Connection closes. 421 $canonical_hostname Shutting down, try later 421 $canonical_hostname Configuration error, try later On connection. Immediate, does not cause anger. 421 $canonical_hostname $loglevel log error: $error, try later SAUCE is having difficulty writing to its logfiles. On connection. Immediate, does not cause anger. 421 $canonical_hostname Internal error, try later Immediate, does not cause anger. Consult the error.log. 421 $canonical_hostname $mta_response Underlying MTA gave unexpected greeting, or unexpected response to HELO/EHLO. 421 $canonical_hostname $printwhat, try later 421 $canonical_hostname $printwhat, try later 421 Too busy ($nconns/$max_like_you $annoy_ms) SAUCE already has too many incoming SMTP connections. config conns_max. On connection. Minor. Anger level string always appended. $nconns is current total number of incoming connections; $max_like_you is the number of simultaneous connections beyond which it will accept no more connections from addresses with which it is as angry as this caller. $annoy_ms is its current anger with the caller in milliseconds. If after the extra anger added by this command SAUCE's anger level is capped by the annoy_grudge_max configuration parameter, SAUCE will firewall out new SMTP SYN packets. config busyfury_firewall_*, firewall_command. 450 $defer_message 450 $rbl_defer_message Response to RCPT TO. The calling site or sender address has not been seen until recently, and mail is being turned away with this temporary failure code for a while. config new_site_message, new_addr_message, rbl. Minor. Anger level string is always shown. 554 First line of header was header field continuation 554 header line too large (>$max_header_size bytes 554 Header data malformed 554 Message-ID header appears twice Major, after data. 554 No Message-ID header 554 Resent- header(s), but no Resent-Message-ID config require_messageid. Major, after data. 554 No originators in envelope or body The MAIL FROM was <> and there were no actual email addresses in any RFC822 originator fields in the header. Major, after data. 550 address $originator: $verification_perm_failure One of the email addresses, $originator, in RFC822 originator fields (From, Sender, etc.) in the header failed to verify. See verification failures, below. Major, after data. Temporary verification failures for originators in message headers do not cause message rejection or deferral. 554 error in $header header: $description The RFC822 originator address header $hn has a syntax error. Major, after data. Descriptions include: invalid text in comment missing end of quoted string invalid data invalid syntax invalid address 554 Blacklisted `$header' 554 Blacklisted originator address `$originator' 554 Blacklisted address `$originator' in headers The RFC822 originator address header $header contained a blacklisted address $originator (only one of these messages will be issued; which depends on the internal workings of SAUCE wrt which data it has available). Major, after data. 550 $blacklist_message Response to message body. Calling site is blacklisted due to this message. config blacklist_message. Major, after data. Address verification errors: A permanent verification failure for an address happens when either a permanent DNS failure happens looking up the MX or A records for the mail domain, or if during the verification the SMTP dialogue goes something like this: << MAIL FROM: verification connection to from.example.com 172.30.206.1: << 220 from.example.com >> MAIL FROM:<> << 250 >> RCPT TO: << 550 Unknown user bogus >> 550 [172.30.206.1] Unknown user bogus Temporary verification errors can happen if with verification SMTP dialogues like this: << MAIL FROM: verification connection to from.example.com 172.30.206.1: << 220 from.example.com >> MAIL FROM:<> << 250 >> RCPT TO: << 450 /home/broken-forward/.forward: syntax error >> 450 Unable to verify: [172.30.206.1] 450 /home/broken-forward/.forward: syntax error or << MAIL FROM: verification connection to from.example.com 172.30.206.1: << 220 from.example.com >> MAIL FROM:<> << 550 I am a really crap mailer >> 450 Unable to verify: [172.30.206.1] MAIL FROM:<> => 550 I am a really crap mailer Various other problems and timeouts can result in temporary verification failures. The messages should be self-explanatory. They can also happen due to temporary DNS failures. DNS errors: Note that the DNS errors reported by SAUCE are largely output from host(1). In the future SAUCE will use adnshost instead of host, and the messages will be quite different. Permanent DNS errors: $domain does not exist. (authoritative answer) $domain has no $type record (authoritative answer) $domain $type record currently not present This message is due to a bug in host(1) misinterpreting certain nameserver replies. It actually means that $domain has no $type record at all, and is treated that way. Temporary DNS errors: If host(1) produces any output (including stderr output) which SAUCE doesn't explicitly understand, this is treated as a temporary failure. Some key ones are listed here: broken-mx.example.com MX host mail-alias.example.com is not canonical Corresponds to eg broken-mx.example.com MX 5 mail-alias.example.com mail-alias.example.com CNAME hermes.example.com hermes.example.com A 172.30.206.4 References: BIND Nameserver Operations Guide: > 5.5.8. CNAME - Canonical Name > > ... Any resource records that include a domain name as their > value (e.g., NS or MX) _must_ list the canonical name, not > the nickname. ... RFC2181 `Clarifications to the DNS Specification' (still at Proposed Standard): > 10.3. MX and NS records > > The domain name used as the value of a NS resource record, or part of > the value of a MX resource record must not be an alias. broken-mx.example.com MX host forgotten.example.com does not exist broken-mx.example.com MX host forgotten.example.com has no A record Nameserver not responding broken-mx.example.com MX record not found, try again broken-mx.example.com MX record not found, server failure These should be obvious (server failure generally refers to the remote nameserver). Reverse DNS lookups can produce error messages of the form: $address -> $host1 -> $problem1;... -> $host2 -> $problem2;... where $host1 etc. are the hostnames suggested by PTR records, and $problem1 etc. are the problems with them. Typical problems are any DNS failure, and also: $different_address_a, $different_address_b, ... if none of the host's addresses match the original address. Eg, a typical error might look something like 172.30.206.1 -> broken-reverse.example.com -> 172.30.206.2, 172.30.206.3 which means that 172.30.206.1 has a PTR pointing to broken-reverse.example.com, which in turn has only the addresses 172.30.206.2 and 172.30.206.3. This file is part of SAUCE, a very picky anti-spam receiver-SMTP. SAUCE is Copyright (C) 1997-2003 Ian Jackson This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. $Id: ERRORS.text,v 1.3 2003/06/15 15:46:40 ian Exp $ work/EXIM-CONFIG.text0000664000000000000000000000400415116102070011332 0ustar Here are some things to do with configuring Exim to work with SAUCE which are worth watching out for: * SAUCE does not do any checking to prevent the local host being used as an open relay. You should configure Exim properly for this, with IP-address-based relay checking. * When passing mail onto the local MTA, SAUCE passes Exim various flags which tell Exim where the mail really came from. The logs will show the mail being received from the far end, even though actually it was done by SAUCE invoking Exim with the `-bs' option. For this to work, the user SAUCE runs as must be an Exim trusted_user. * SAUCE will sometimes make an SMTP connection to one of the local system's IP addresses so that it can see if an address is valid. It is helpful if receiver verification is only disabled on localhost, if at all. * It is best to configure Exim with a stringent set of checks as well as SAUCE. Exim and SAUCE's checks are often complementary. * RBL: Exim can use RBLs for inserting warning messages or blocking mail, and SAUCE can use them for blocking or delaying mail. If you want mail blocked it is better to use SAUCE because you get better control over the resulting error messages. This file is part of SAUCE, a very picky anti-spam receiver-SMTP. SAUCE is Copyright (C) 1997-2003 Ian Jackson This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. $Id: EXIM-CONFIG.text,v 1.3 2003/06/15 15:46:40 ian Exp $ work/INSTALL.text0000664000000000000000000000614115116102070010737 0ustar Installation instructions for SAUCE: Note: I have not had time to write a proper set of installation instructions. Furthermore, I have never installed SAUCE other than as a Debian package (built from the source tree you have here). In general, you should be able to edit the variable settings at the top of the Makefile and run `make && make install && make databases' or some such. SAUCE will function with a nearly-empty configuration file. The configuration variables are listed in sconfig.tcl, though there is no documentation for them yet. For your enlightenment I've also included a copy of the config file for chiark.greenend.org.uk, as example-config.text. SAUCE expects to be able to bind to the SMTP port and listen for incoming connections on it, but it also expects not to be root. You should not run SAUCE as root, because there is no good reason to do so. I make SAUCE able to bind to the local SMTP port by by using `authbind', which is a package in Debian GNU/Linux which does some magic with LD_PRELOAD. See www.debian.org, or look for the source on ftp.debian.org in dists/stable/main/source/utils/authbind*. If you want users to be able to modify SAUCE's blacklists and whitelists, you will need userv (`you-serve', http://www.chiark.greenend.org.uk/~ian/userv/). SAUCE will sometimes want to firewall out incoming SMTP connection requests. If you have userv, and Linux 2.2 ipchains, then this should work if you set up the appropriate hook for SAUCE, with something like this: ipchains -A input -j ACCEPT -i lo ... # Deal with repeated SMTP connects which SAUCE wants to blackhole ipchains -N Sauce ipchains -A input -j Sauce -i eth0 -p tcp -y -d HOST.EXAMPLE.COM smtp The supplied userv configuration should make SAUCE able to edit the `Sauce' chain. If you run some other operating system you should still be able to get it to work. SAUCE will periodically call: userv root sauce-firewall [ ...] This should result in future SMTP SYN packets from the listed addresses (to SAUCE) to be dropped (or possibly rejected, if you're feeling nice). Each call will have a complete new block list. The list may be empty, in which case no addresses should be firewalled. See also EXIM-CONFIG.text for some information about configuring Exim to work properly with SAUCE. This file is part of SAUCE, a very picky anti-spam receiver-SMTP. SAUCE is Copyright (C) 1997-2003 Ian Jackson This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. $Id: INSTALL.text,v 1.4 2006/04/02 18:13:16 ian Exp $ work/Makefile0000664000000000000000000000654115116102070010367 0ustar ########### Makefile # Edit the settings below, if you like, and say `make install'. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: Makefile,v 1.27 2006/04/02 18:30:36 ian Exp $ # Edit these variables, if you want to: prefix=/usr/local var_base=/var var_dir=$(var_base)/lib/sauce log_dir=/var/log/sauce etc_dir=/etc tclsh=/usr/bin/tclsh var_run_dir=$(var_base)/run fw_lockfile=$(var_run_dir)/sauce-firewall.lock username=mail userlist=/etc/userlist bin_dir=$(prefix)/bin sbin_dir=$(prefix)/sbin share_dir=$(prefix)/share sharelib_dir=$(share_dir)/sauce doc_dir=$(share_dir)/doc/sauce config_dir=$(etc_dir)/sauce userv_dir=$(etc_dir)/userv uservserv_dir=$(userv_dir)/services.d INSTALL=/usr/bin/install INSTALL_DATA=$(INSTALL) -c INSTALL_PROGRAM=$(INSTALL) -c # You should not need to edit anything beyond this point. # # VERSION= 0.1 USERV_SERVS= sauce-userblacklist sauce-firewall sauce-rcptpolicy TCL_LIBS= readlibs readconf library thread dns avf avfpool \ smtp msgdata notifybl datastate yesmaster sconfig stall TCL_USEREXECS= sauce-bwlist sauce-setuserpolicy TCL_SYSEXECS= sauce sauceadmin sauce-setsyspolicy sauce9-convert \ sauce-await-startup TCL_LIBEXECS= firewall rcpt-policy clean-site-annoy convertdb TARGETS= $(TCL_USEREXECS) $(TCL_SYSEXECS) $(TCL_LIBEXECS) \ $(TCL_LIBS) $(USERV_SERVS) DOC_FILES= BLURB.text README.text ERRORS.text EXIM-CONFIG.text \ INSTALL.text POLICY-CONFIG.text all: $(TARGETS) install: $(TARGETS) $(INSTALL_DATA) $(TCL_LIBS) $(sharelib_dir) $(INSTALL_PROGRAM) $(TCL_LIBEXECS) $(sharelib_dir) $(INSTALL_PROGRAM) $(TCL_USEREXECS) $(bin_dir) $(INSTALL_PROGRAM) $(TCL_SYSEXECS) $(sbin_dir) set -e; for f in $(USERV_SERVS); do \ $(INSTALL_DATA) $$f $(uservserv_dir)/$$f:example; \ done databases: SAUCE9_CONVERTB=./convertdb sauce9-convert $(var_dir) install_doc: $(DOC_FILES) $(INSTALL_DATA) $(DOC_FILES) $(doc_dir) settings: Makefile $(tclsh) setsettings.tcl >$@-n \ _tclsh "$(tclsh)" \ var_dir "$(var_dir)" \ log_dir "$(log_dir)" \ sbin_dir "$(sbin_dir)" \ config_dir "$(config_dir)" \ share_dir "$(sharelib_dir)" \ readlibs "$(sharelib_dir)/readlibs" \ username "$(username)" \ userlist "$(userlist)" \ fw_lockfile "$(fw_lockfile)" \ tcl_lib_ext? "" @mv -f $@-n $@ %: %.tcl settings $(tclsh) subst.tcl settings $< %: %.in settings $(tclsh) subst.tcl settings $< clean distclean: rm -f settings $(TARGETS) *.new *~ ./#*# *.bak rm -f debian/*~ debian/#*# debian/*.bak rm -f cdb.addr-seen.main cdb.addr-list.log rm -f cdb.site-seen.main cdb.site-list.log rm -f cdb.site-annoy.main cdb.site-annoy.log work/POLICY-CONFIG.text0000664000000000000000000002131215116102070011570 0ustar SAUCE POLICY and RECIPIENT CLASSES ---------------------------------- SAUCE can (and should) be configured to treat different recipient addresses differently. When a RCPT command is received, SAUCE will determine what class the proposed recipient falls into. Then, depending on the class, it will decide whether to accept, defer or reject this recipient; the classes accepted for a particular message can also affect SAUCE's behaviour after it has received the message body. The categorisation of recipient addresses into classes may change from time to time or from message to message depending on other available information. RECIPIENT CLASSES ----------------- The recipient classes are: normal All normal SAUCE checking on the sending site's DNS and mail system, and on the syntax and semantics of the message headers, will be done. Mail from new sites and new senders will be delayed according to the configured policy. nodelay All the normal checks are done. However, mail will not be deferred solely because the sender or site is previously unknown to SAUCE. bait The address has been published in a way that will hopefully get it included in spammers' recipient lists, and never been published in a way that a human might accidentally mail it. SAUCE will blacklist the sending site and/or email addresses, according to its configuration. Mail for bait addresses is (usually) accepted and discarded, so that the bait addresses are not removed from spammers' lists. unchecked None of SAUCE's policy checks will be done. The intent is that SAUCE's behaviour for mail for unchecked recipients not be significantly different from that of the underlying MTA. HOWEVER: a single message delivery cannot go to both unchecked and normal/nodelay recipients, because SAUCE would be faced with a dilemma if the headers had policy problems - it would neither be correct to bounce, nor to accept, the mail. To avoid this, if SAUCE has already accepted a normal/nodelay address and is offered an unchecked one, or vice versa, SAUCE will defer the later address with a `450'. The calling site must retry the deferred address, but in practice may do so only some time later (and if it is broken, not at all). This means that messages sent to a mixture of normal/nodelay addresses and unchecked addresses will *usually* be significantly delayed for at least some recipients. For this reason unchecked addresses should be used sparingly; they are intended for mail administration role addresses such as postmaster which *must* not reject mail spuriously. lax None of SAUCE's policy checks that can be applied at the RCPT stage will be done, and unless the same message is also sent to some normal/nodelay recipients, lax is just the same as unchecked. However, if single message is sent to a mixture of lax and normal/nodelay addresses, problems with its headers may cause the whole message transaction to be rejected, so that even the lax recipient will not receive it. This avoids the problem with `unchecked' above: instead of deferring the later address class with `450', SAUCE will accept all the recipients, but risk rejecting the whole mail - even for the lax recipients - if the headers reveal problems. 450 451 452 550 552 553 These recipient classes specify directly the response to be sent to the RCPT command. Usually 550 or 450 should be used. Ordinary mail recipient addresses should use one of normal, nodelay or lax, along with possibly 550 to block specific kinds of mail. When to use lax and when to use unchecked ? ------------------------------------------- lax and unchecked are identical for messages which are not also sent to some normal/nodelay addresses, or for messages/sites with problems which SAUCE detects before seeing the headers. The only difference between them comes when a single message is sent to both normal/nodelay and lax/unchecked addresses (and there are no problems which show up before the message headers are seen). With unchecked, whenever such a message is sent, at least some of the recipients will recieve their copy of the mail late - even if there is nothing wrong with the mail, and they are regular correspondents. However, the unchecked recipients will receive the mail even if the headers are broken. With lax, if the message has no problems revealed by the headers, it will be delivered without delay to all of the recipients. However, if the headers have problems then the mail will be rejected after the body has been received, and so none of the recipients will receive it. Therefore, `unchecked' is more appropriate for administrative and problem-reporting addresses. `lax' should be used for normal correspondence, to avoid spurious delays to routine mail. POLICY FILE SYNTAX ------------------ SAUCE can be configured by the use of recipient policy files. These are a series of lines which look like this [-] followed by a single line containing only `.'. Blank lines are permitted. Lines starting with # are comments. is one of [] [/] (where the [ and ] are literals and must actually appear surrounding the address or mask/length.) is one of @ (not ending in @) (To match `<>' when specified as envelope sender, match `@' instead.) globs may contain no whitespace. They support [...], ? and * and \-escapes for those metacharacters. There is no way to specify patterns including whitespace. is currently either omitted completely, or `errok'. Sending sites which generate errors when trying to mail (only) `errok' addresses will not make SAUCE angry; instead each such error will simply have the anger penalty acted out straight away and then forgotten. is the address class, ie one of 450|451|452|550|552|553 normal|lax|nodelay|bait|unchecked as specified above. The first matching line in the policy is determining. INSTALLING AND USING POLICY --------------------------- When a RCPT is issued the SAUCE configuration may direct that a policy file be used. This is done with the addr_regexp configuration directive. Policy files have to be compiled and installed into SAUCE's internal policy directory (/var/lib/sauce/policies by default), using the sauce-setsyspolicy and sauce-setuserpolicy commands. There are two special kinds of `class' which can be used in addr_regexp, `policy' for system policies specified by the administrator, and `user' for policies specified by individual users using userv. They work as follows: Recipient class Subpolicy argument in addr_regexp to sauce-set*policy Default policy file policy /etc/sauce/policy policy= : /etc/sauce/policy: policy=: ::$1 /etc/sauce/policy::$1 user ~$1/.sauce-policy user= ~/.sauce-policy user=: :$1 ~/.sauce-policy:$1 user=: : ~/.sauce-policy: user=:: ::$1 ~/.sauce-policy::$1 Here $1 is the first regexp match substring string from the addr_regexp, after the destination address has matched. In the regexp match all characters except 7-bit alphanumerics and the puncutuation characters - + _ . % $ will be replaced with ?, and if there are any more than 126 characters all extra ones will be replaced with *, before the relevant policy is looked up. Do not attempt to set or use policies whose names contain `/'. In any case, if the relevant policy has not been installed, or no line in the policy matches, then the addr_regexp processing continues as if the regexp had not matched. $Id: POLICY-CONFIG.text,v 1.3 2003/09/07 22:49:20 ian Exp $ work/README.text0000664000000000000000000000245115116102070010566 0ustar See BLURB.text for a description of SAUCE's features, pros and cons, etc. See ERRORS.text for a brief summary of each of SAUCE's error messages. See INSTALL.text for some sketchy information about how to install SAUCE. See EXIM-CONFIG.text for some hints about configuring Exim to work well with SAUCE. See debian/changelog for the change history. SAUCE is Copyright (C) 1997-2003 Ian Jackson This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. As a special exception, blmessage.text is placed in the public domain. (This is necessary because SAUCE will redistribute this file itself, with no copyright message, in normal operation.) $Id: README.text,v 1.4 2003/06/15 15:46:40 ian Exp $ work/TODO0000664000000000000000000000727215116102070007421 0ustar WISHLIST * Review logging to ensure that it's as consistent as it could be. * URL in SMTP error messages. * Call adnshost only once. * Check for message dates in the future or far past. IMPORTANT * Allow avf to succeed on ip-literals * Do something to allow `irritated' etc. to be less `rude'. * MBM's bug with quoted local-parts (to sauce-maint==ian@davenant, 30 May 2001 17:20:19 +0000 and my reply 26 Sep 2001 00:44:11 +0100) * MBM's bug with RBL and TXT vs A (Thu, 31 May 2001 13:14:49 +0100 and Wed, 6 Jun 2001 19:14:38 +0100) -chiark:sauce> grep 195.41.46.237 cdb.site-list.main +13,24:195.41.46.237->0x00000000451b3aa0 black -chiark:sauce> grep 195.41.46.237 cdb.site-list.jrn -chiark:sauce> -chiark:sauce> zgrep 195.41.46.237 /var/log/sauce/dbreasons.log* -chiark:sauce> * Allow A RR masking in rbls * fix up log rotation * search for instances of `==' and `!=' on strings accept local parts "with space"@example -anarres:~> telnet anarres 8430 Trying 172.18.45.2... Connected to anarres.relativity.greenend.org.uk. Escape character is '^]'. 220 anarres.relativity.greenend.org.uk sauce-smtpd ESMTP ready [Oh, master!] ehlo anarres.relativity.greenend.org.uk 250-anarres.relativity.greenend.org.uk hello ian@anarres.relativity.greenend.org.uk (postmaster@anarres.relativity.greenend.org.uk?) 250-SIZE 250-8BITMIME 250 PIPELINING BUT 2006-04-02 23:06:32 BST: debug: dns 3 error {Internal error: unexpected status: 301 nodata} also need logging of questions and answers stupid toobusy behaviour: Diziet: I've been having some SAUCE-related pain recently. Could you +please explain why new_conn_checkbusy is the way is? > mdw: Err, what specific aspect of it do you dislike ? The algorithm is +known not to be ideal. > The main purpose is to reserve capacity for known-good sites and to punish +sites which are excessively `enthusiastic'. Diziet: So, suppose I'm in its bad books for some minor infraction: it's +slightly irritated and terribly busy, so it wants to tell me to go away. +This causes me to be put in the firewall chain for 13 hours. However, were I +very bad and evil, and made it furious at me, it would merely tell me to go +away and leave me hanging for a while. I'm puzzled about why it doesn't firewall people it's really mad at, but +does firewall people who've only annoyed it a little bit. > mdw: Yes, that's how the algorithm is fundamentally incorrect. Diziet: Ahh. I think I've fixed the things that were upsetting it, but it made me +curious anyway. > mdw: It ought to do something more sane like dropping `irritated' people +with 421 and no firewall and more angry people into the +221-i'll-be-right-with-you tarpit and use the firewall for if the tarpit is +full. Diziet: That's what I expected it to want to do, certainly. > s/221/220/ # of course > mdw: If it's very annoying to you I could reset the annoyance, or you could +use a different IP address. > Or ssh tunnel to chiark:25; chiark's own SAUCE never gets annoyed with +chiark's IP address. Diziet: It's happy with me now. I've learned how to sooth its ruffled +feathers. > NOOP NOOP NOOP ? :-) > Giving it mail it likes works too but is harder work. That, and sending myself uninteresting mail. also stuck connections: -rw-r--r-- 1 mail mail 40162910 Apr 3 20:14 debug.log -rw-r--r-- 1 mail mail 28348917 Apr 3 12:42 debug.log.0 -chiark:sauce> cat debug.log.0 debug.log | grep 217.122.192.2 |less also broken thing: 2006-04-03 20:13:52 BST: error: Tcl error dnsptr 9657 dns_rverr {shut down}:\n can't unset "state(dnsid)": no such variable\n while executing\n"unset state(dnsid)"\n (procedure "dnsptr//dns_rverr" line 3)\n invoked from within\n"dnsptr//dns_rverr....... work/asynch.tcl0000775000000000000000000000401315116102070010713 0ustar #!/usr/bin/tclsh # This [sub]program is Copyright (C) 1997-2001 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: asynch.tcl,v 1.11 2006/04/03 00:56:38 ian Exp $ proc asynch_startcmd {} { global asynch_sofar set asynch_sofar {} puts -nonewline "% " flush stdout } proc morecmd {} { global asynch_sofar asynch_result asynch_code errorInfo set r [read -nonewline stdin] if {[eof stdin]} { fconfigure stdin -blocking true puts -nonewline "\n" exit 0 } append asynch_sofar $r if {[info complete $asynch_sofar]} { uplevel #0 {set asynch_code [catch $asynch_sofar asynch_result]} if {$asynch_code} { puts "** $errorInfo" flush stdout } elseif {[string length $asynch_result]} { puts "=> $asynch_result" } flush stdout asynch_startcmd } } if {[llength $argv] && "[lindex $argv 0]" == "-d"} { set tcl_traceExec 1 set argv [lreplace $argv 0 0] } elseif {[llength $argv] && "[lindex $argv 0]" == "-dd"} { set tcl_traceExec 2 set argv [lreplace $argv 0 0] } if {[llength $argv] && [regexp {^-a(\d+)$} [lindex $argv 0] asynch_dummy asynch_appdebug]} { set argv [lreplace $argv 0 0] } if {[llength $argv]} { set asynch_script [lindex $argv 0] set argv [lreplace $argv 0 0] source $asynch_script } asynch_startcmd fileevent stdin readable morecmd fconfigure stdin -blocking false vwait asynch_quitting work/avf.tcl0000664000000000000000000002552715116102070010214 0ustar ########## avf.tcl # # Address verification functions # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: avf.tcl,v 1.24.2.1 2008/03/08 15:53:08 ian Exp $ ########## avf threads # thread_start avf $desc $localpart $domain # # success => 1 $message # permanent failure => 0 $message # temporary failure =>X # state variables: # dm domain to be verified # qaddr quoted address to be verified # tempfaillev level of temp failure \ temp fail msgs with level>tempfaillev # tempfail temp failure message / will be stored in tempfail # alltoid overall timeout id # dnsid dns query sub-thread (unset => none) # vc channel for connection to remote SMTP # vccount see avfpool count argument/result # caddr IP address we're connected to (plus . if it's a fresh conn) # mxhosts list of MX record contents, including the preferences, # not including any that have already been tried, or whose # addresses are in mxaddrs, or which are currently being # looked up; set only in later stages of processing # mxaddrs list of addresses of MX's which we are currently trying; # set only in later stages of processing (first entry may # have . appended if we must try a fresh conn). # mxerror error encountered while trying to find the MX records # toid individual timeout (unset => none) # conncurrently what we are currently doing on conn \ used to update tempfail # conncurrentlylev error level if it doesn't work / if things don't work out thread_typedefine avf {localpart domain} { global verify_all_timeout avfpoolid if {![domain_ok $domain]} { thread_finish avf $id 0 "syntax error in domain" return } set state(dm) $domain set state(qaddr) [lp_quote $localpart]@$state(dm) if {[thread_crosscall avfpool $avfpoolid addr_checkcache $state(qaddr)]} { thread_finish avf $id 1 "Verified (cached)" return } set state(tempfaillev) 0 set state(tempfail) "unknown failure" set state(alltoid) [thread_after avf $id $verify_all_timeout timeout] set state(dnsid) [thread_start dns $state(desc) $domain MX 0] thread_join avf $id dns $state(dnsid) mx_ok {} } ERROR-ON-SHUTDOWN { catch { thread_cancel dns $state(dnsid) } catch { after cancel $state(alltoid) } catch { after cancel $state(toid) } catch_close_cleardesc state(vc) } thread_chainproc avf timeout {} { unset state(alltoid) thread_error avf $id "verification timed out; $state(tempfail)" {} } thread_chainproc avf mx_ok {answers emsgstr how} { unset state(dnsid) switch -exact -- $how { OK { set state(mxhosts) [lsort -index 0 -integer $answers] set state(mxaddrs) {} avf_tempfail 10 "unable to find address for any mx for $state(dm)" avf_tryaddrs } NXDOMAIN - MISCONFIG { thread_finish avf $id 0 "$emsgstr" } NOTYPE { set state(mxerror) $emsgstr set state(dnsid) [thread_start dns $state(desc) $state(dm) A 0] thread_join avf $id dns $state(dnsid) afallback_ok {} } default { thread_error avf $id "$how" {} } } } thread_chainproc avf afallback_ok {answers emsgstr how} { unset state(dnsid) if {"$how" == "OK"} { set state(mxhosts) {} set state(mxaddrs) $answers avf_tempfail 20 "unable to contact (non-MX) host $state(dm)" avf_tryaddrs } else { thread_finish avf $id 0 "$state(mxerror); $emsgstr" } } thread_subproc avf tryaddrs {} { global remote_port verify_perconn_timeout global avfpoolid global avfchancounter while 1 { if {[llength $state(mxaddrs)]} { set caddr [lindex $state(mxaddrs) 0] set state(mxaddrs) [lreplace $state(mxaddrs) 0 0] if {[regsub {\.$} $caddr {} caddr_addr]} { set state(vc) {} } else { manyset [thread_crosscall avfpool $avfpoolid \ chan_retrieve $caddr] \ state(vc) state(vccount) } if {[string length $state(vc)]} { set state(caddr) $caddr_addr set state(toid) [thread_after avf $id \ $verify_perconn_timeout conntimedout] avf_haveconnection return } elseif {[catch { set state(vc) [socket -async $caddr_addr $remote_port] incr avfchancounter chanset_desc $state(vc) "verify $caddr:smtp $avfchancounter" } emsg]} { avf_tempfail 40 "attempt connection to \[$caddr\]: $emsg" continue } else { fconfigure $state(vc) \ -translation {binary crlf} -blocking false set state(caddr) $caddr_addr. avf_conncurrently 43 "connect" set state(toid) [thread_after avf $id \ $verify_perconn_timeout conntimedout] thread_fileevent avf $id $state(vc) writable connected return } } elseif {[llength $state(mxhosts)]} { set state(dnsid) [thread_start dns $state(desc) \ [lindex [lindex $state(mxhosts) 0] 1] addr 0] set state(mxhosts) [lreplace $state(mxhosts) 0 0] thread_join avf $id dns $state(dnsid) addr_ok addr_err return } else { thread_error avf $id $state(tempfail) {} return } } } thread_chainproc avf addr_ok {answers_all emsgstr how} { unset state(dnsid) set state(mxaddrs) {} foreach answer $answers_all { manyset $answer atype avalue switch -exact $atype { INET { # append, see below } INET6 { # Ideally we would support this, but we would want to # have a way to bind to a separate outgoing address. continue } default { # Some AF we don't support. continue } } lappend state(mxaddrs) $avalue } avf_tempfail 30 "unable to contact any mail exchanger for $state(dm)" avf_tryaddrs } thread_chainproc avf addr_err {emsg} { unset state(dnsid) avf_tryaddrs } thread_chainproc avf conntimedout {} { catch_close_cleardesc state(vc) catch { unset state(vccount) } unset state(toid) avf_tempfail $state(conncurrentlylev) "$state(conncurrently) timed out" avf_tryaddrs } thread_chainproc avf connected {} { if {[catch { set state(lh) [lindex [fconfigure $state(vc) -sockname] 1] } emsg]} { thread_error avf $id \ "get local host name for verification socket to \[$state(caddr)\]: $emsg" {} } fileevent $state(vc) writable {} avf_conncurrently 45 "greeting wait" threadio_commandresponse avf $id $state(vc) {} {^220|^55.} \ greeting_ok vc_err } thread_chainproc avf greeting_ok {data} { if {[avf_response_ok_but5xx "banner:" $data]} return avf_conncurrently 50 "EHLO" threadio_commandresponse avf $id $state(vc) "EHLO $state(lh)" \ {^[25]..} ehlo_ok vc_err } thread_chainproc avf ehlo_ok {data} { global canonical_hostname set state(vccount) 0 if {[regexp {^2[0-9][0-9]} $data]} { if {[regexp -nocase {(?m)^2[0-9][0-9][- ][ \t]*pipelining[ \t]*$} \ "$data\n"]} { set state(vccount) -1 } avf_haveconnection } else { avf_conncurrently 50 "HELO" threadio_commandresponse avf $id $state(vc) \ "HELO $canonical_hostname" {^2..} helo_ok vc_err } } thread_chainproc avf helo_ok {data} { avf_haveconnection } thread_subproc avf haveconnection {} { avf_conncurrently 60 "MAIL FROM:<>" if {$state(vccount) < 0} { threadio_commandresponse avf $id $state(vc) \ "MAIL FROM:<>\nRCPT TO:<$state(qaddr)>\nRSET" \ {^[25]..} mailfrom_ok_pipelining vc_err } elseif {$state(vccount) == 0} { threadio_commandresponse avf $id $state(vc) "MAIL FROM:<>" \ {^[25]..} mailfrom_ok_synch vc_err } else { avf_rcptto_synch } } thread_chainproc avf mailfrom_ok_pipelining {data} { if {[avf_response_ok_but5xx "MAIL ->" $data]} return avf_conncurrently 70 "RCPT TO (for verify, pipelining)" threadio_commandresponse avf $id $state(vc) "" \ {^[245][0-9][0-9]} rcptto_done_pipelining vc_err } thread_chainproc avf rcptto_done_pipelining {data} { avf_conncurrently 80 "RSET (for verify, pipelining)" threadio_commandresponse avf $id $state(vc) "" \ {^2..} rset_ok_pipelining vc_err $data } thread_chainproc avf rset_ok_pipelining {rcptdata data} { avf_rcpt_process $rcptdata } thread_chainproc avf mailfrom_ok_synch {data} { if {[avf_response_ok_but5xx "MAIL =>" $data]} return avf_rcptto_synch } thread_subproc avf vc_kill {} { after cancel $state(toid) unset state(toid) catch { threadio_puts_throw $state(vc) "QUIT\r\n" } catch_close_cleardesc state(vc) catch { unset state(vccount) } } thread_subproc avf response_ok_but5xx {context data} { if {[regexp {^2..} $data]} { return 0 } avf_vc_kill avf_result 0 "$context $data" return 1 } thread_subproc avf rcptto_synch {} { avf_conncurrently 70 "RCPT TO (for verify)" threadio_commandresponse avf $id $state(vc) "RCPT TO:<$state(qaddr)>" \ {^[245][0-9][0-9]} rcptto_done_synch vc_err } thread_chainproc avf rcptto_done_synch {data} { avf_rcpt_process $data } thread_subproc avf rcpt_process {data} { global avfpoolid if {[regexp {^2[0-9][0-9].*} $data text]} { thread_crosscall avfpool $avfpoolid addr_addcache $state(qaddr) set result 1 } elseif {[regexp {^5[0-9][0-9].*} $data text]} { set result 0 } else { avf_tempfail 90 "\[$state(caddr)\] $data" avf_vc_failed return } regsub {\.$} $state(caddr) {} caddr_addr thread_crosscall avfpool $avfpoolid chan_place \ $caddr_addr $state(vc) $state(vccount) unset state(vc) unset state(vccount) avf_result $result $text } thread_subproc avf result {ok text} { regsub -all {(?m)^(2[0-9][0-9]\-?[ \t]*)?} $text "\[$state(caddr)\] " text thread_finish avf $id $ok $text } thread_chainproc avf vc_err {args} { set emsg [lindex $args end] avf_tempfail $state(conncurrentlylev) \ "\[$state(caddr)\] $state(conncurrently) => $emsg" avf_vc_failed } thread_subproc avf vc_failed {} { avf_vc_kill if {![regexp {\.$} $state(caddr)]} { # try again with a new connection set state(mxaddrs) [concat $state(caddr). $state(mxaddrs)] } avf_tryaddrs } thread_subproc avf conncurrently {lev what} { append what " \[$state(caddr)\]" set state(conncurrently) $what set state(conncurrentlylev) [expr {$lev+1}] avf_tempfail $lev "$what failed" } thread_subproc avf tempfail {lev msg} { if {$state(tempfaillev) < $lev} { set state(tempfail) $msg set state(tempfaillev) $lev } } work/avfpool.tcl0000664000000000000000000001427215116102070011101 0ustar ########### avfpool.tcl # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: avfpool.tcl,v 1.9 2003/06/15 15:46:40 ian Exp $ ########## avfpool thread # thread_start avfpool $desc # # thread_crosscall avfpool $avfpoolid chan_retrieve $ipaddress # => [list $channel $count] # channel channel id, for which caller is now responsible # count number of recipients for the current message: # 0 -> MAIL FROM not yet done, caller must # discard channel if it fails # >0 -> that many, can do at least one more # -1 -> PIPELINING supported, MAIL FROM not yet # done, caller must RSET after use, and # discard channel if RSET fails # OR # => {} # # thread_crosscall avfpool $avfpoolid chan_place $ipaddress $channel $count # channel channel id, as before. avfpool is now responsible # count count value, as got back from retreive. avfpool # will increment this, so caller doesn't need to # # thread_crosscall avfpool $avfpoolid addr_checkcache $address # => 1 -> address verified recently and is OK # => 0 -> address not verified recently or not OK # # thread_crosscall avfpool $avfpoolid addr_addcache $address # => {} # only call this if you have actually verified the address, not # if you got it out of the cache # state variables: # chl list of channels, each entry is [list $chan $ipaddr $toid $count] # chlrset list of channels currently awaiting RSET completion, # each entry is [list $chan $ipaddr $toid] # chlclosing list of channels currently being closed, entry is [list $chan $toid] # # global variables: # avfpool_eaddrcache array indexed by email address; answer is timeout id for expiry thread_typedefine avfpool {} { global avfpool_eaddrcache set state(chl) {} set state(chlrset) {} set state(chlclosing) {} catch { unset avfpool_eaddrcache } } NO-CLEAN-SHUTDOWN { global avfpool_eaddrcache log error "avfpool died, clearing out !" foreach chlwhich {chl chlrset chlclosing} { catch { foreach che $state($chlwhich) { manyset $che chan toid catch_close_cleardesc chan catch { after cancel $toid } } } } catch { foreach toid [array names avfpool_eaddrcache] { catch { after cancel $avfpool_eaddrcache($toid) } } } catch { unset avfpool_eaddrcache } } thread_chainproc avfpool chan_retrieve {ipaddress} { set ix 0 foreach che $state(chl) { manyset $che chan toid ipaddr count if {"$ipaddr" == "$ipaddress"} { after cancel $toid set state(chl) [lreplace $state(chl) $ix $ix] return [list $chan $count] } incr ix } return {} } thread_chainproc avfpool chan_place {ipaddress chan count} { global max_verify_rcpts verify_rset_timeout verify_reuse_timeout if {$count >= $max_verify_rcpts} { set toid [thread_after avfpool $id $verify_rset_timeout rset_timedout $chan {}] lappend state(chlrset) [list $chan $toid $ipaddress] threadio_commandresponse avfpool $id $chan rset {^2..} rset_ok rset_failed $chan } else { if {$count >= 0} { incr count } set toid [thread_after avfpool $id $verify_reuse_timeout chanuse_timedout $chan] lappend state(chl) [list $chan $toid $ipaddress $count] } } thread_chainproc avfpool rset_ok {channel data} { global verify_reuse_timeout manyset [avfpool_retrdata chlrset $channel] chan toid ipaddr after cancel $toid set toid [thread_after avfpool $id $verify_reuse_timeout chanuse_timedout $chan] lappend state(chl) [list $chan $toid $ipaddr 0] } thread_chainproc avfpool rset_failed {channel why} { manyset [avfpool_retrdata chlrset $channel] chan toid ipaddr after cancel $toid catch_close_cleardesc chan } thread_chainproc avfpool rset_timedout {channel} { manyset [avfpool_retrdata chlrset $channel] chan toid ipaddr catch_close_cleardesc chan } thread_chainproc avfpool chanuse_timedout {channel} { global verify_quit_timeout manyset [avfpool_retrdata chl $channel] chan toid ipaddr count set toid [thread_after avfpool $id $verify_quit_timeout quit_timedout $chan] lappend state(chlclosing) [list $chan $toid] threadio_commandresponse avfpool $id $chan QUIT {^221} quit_done quit_done $chan } thread_chainproc avfpool quit_done {channel data} { manyset [avfpool_retrdata chlclosing $channel] chan toid after cancel $toid catch_close_cleardesc chan } thread_chainproc avfpool quit_timedout {channel} { manyset [avfpool_retrdata chlclosing $channel] chan toid catch_close_cleardesc chan } thread_subproc avfpool retrdata {chlwhich channel} { set ix 0 foreach che $state($chlwhich) { if {"[lindex $che 0]" == "$channel"} { set state($chlwhich) [lreplace $state($chlwhich) $ix $ix] return $che } incr ix } error "channel $channel not found in $chlwhich $state($chlwhich)" } thread_chainproc avfpool addr_checkcache {address} { global avfpool_eaddrcache return [info exists avfpool_eaddrcache($address)] } thread_chainproc avfpool addr_addcache {address} { global avfpool_eaddrcache verify_cache_timeout if {[info exists avfpool_eaddrcache($address)]} { after cancel $avfpool_eaddrcache($address) } set avfpool_eaddrcache($address) [thread_after avfpool $id \ $verify_cache_timeout addr_timedout $address] } thread_chainproc avfpool addr_timedout {address} { global avfpool_eaddrcache unset avfpool_eaddrcache($address) } work/blmessage-addr.text0000664000000000000000000001240315116102070012501 0ustar Remain calm! Please read all of this message before acting. We have received mail claiming to be from your email address (see the Subject) that our system thinks is junk mail, because it was sent to a `spambait' address. We have therefore made an entry for you in our blacklist which will block mail claiming to be from that address, for a short period of time. This message has been sent automatically to let you know. Assuming that you are not a spammer, and do not have any email viruses infecting your system, then your email address was blacklisted because a spammer or virus forged the return address, using your email address without your permission or knowledge. As well as my system's blacklist notification you may have received a large number of bounces (nondelivery reports and error messages) relating to messages you did not send. This message is sent as a courtesy to let you know that someone is forging mail in your name. Also, we send this notification in case you did in fact send the email in question, to let you know that your mailing list is not properly opt-in, which would make you a spammer. The blacklist entry will last only a short while: long enough to block the particular spam run. So, unless you often send mail to our system, you are unlikely to have any of your own legitimate mail blocked. There is therefore no need to reply to this message to ask to be removed from the blacklist. Thank you for your attention. Answers to common questions: Q. Please remove me from your blacklist immediately ! A. There is no need to get yourself removed from our blacklist unless you plan to send mail to one of our users. Our email address blacklist is not published or used by any other system, so only mail you send to us will be blocked. It will be less trouble for all of us just to let the blacklist entry expire in a few days. However, if you really insist on being removed immediately, or expect to have to mail us in the near future, please contact us according to the instructions below. Q. If you think the sender address is forged, why do you blacklist me anyway ? A. This situation (junkmail with forged sender address) is very common nowadays, which might suggest that it would be a bad idea to create blacklist entries for sender addresses at all. However, since many spammers and some viruses do still send out large runs of junk with fixed return addresses, it is still worthwhile blacklisting the claimed return address, if only for a short while, despite the fact that sometimes innocent people will get blacklisted. Q. What can I do about this outrageous abuse of my email address ? A. In the case of spam, although in theory it should be possible to sue the spammer, for abusing your email address in this way, in practice finding their name and address from the available information is often very difficult, and will involve a lot of arguing with hostile Internet Service Providers and other unhelpful people - and that's even before you've got to an actual lawsuit. If you are truly prepared to go down this route, we would be very happy to help by providing the information we have about the spam or virus, including the exact time that the spam was received by our system and the IP address of the machine that passed it to us (note that usually spammers abuse ill-configured innocent third parties' systems, so further tracing will be required). Unfortunately this information is quite limited since we do not keep copies of the junk mails. In the case of a virus, the situation is even worse: depending on your jurisdiction, and the jurisdiction of the person whose computer was infected, you probably don't have any recourse at all. If you like tilting at windmills you could sue Microsoft, whose poor software is responsible for the prevalence of viruses. Otherwise, I'm afraid, you'll just have to put it down to experience. Write to your local legislators to urge them to pass effective anti junk mail legislation which puts the cost burden on the ISPs providing connectivity to spammers, and on the operators of insecure computers which launch attacks or forge mail. If you want to join the fight against spam you might like to start by looking at the Coalition Against Unsolicited Commercial Email, http://www.cauce.org/. Unfortunately there does not currently (January 2003) seem to be a campaign fighting the root causes of virus spew. Q. What is a `spambait address' ? A. A spambait address is one which is published in newsgroups, web pages, etc., in a way that will encourage automated address harvesters to pick it up, but with context which clearly discourages the human reader from using the address. Whenever our system receives a mail for a bait address it automatically blacklists the sender. Q. I would like to contact you to discuss your blacklisting policies. A. Certainly. Please read the Q-and-A above, and if your question is still not answered then you should contact us using the address `sauce-admin' at the hostname above. Ie, replace `sauce-daemon' with `sauce-admin'. That will bypass the blacklist. Do not reply directly to this message, to `sauce-daemon', as such mail is blocked or ignored. -- work/blmessage-site.text0000664000000000000000000002312315116102070012534 0ustar Remain calm! Please read all of this message before acting. We have received mail from your site that our system thinks is junk mail, because it was sent to a `spambait' address. We have therefore made an entry for you in our blacklist for the offending system's IP address (see the Subject line). This blacklist entry will last for a considerable time. The Date header of this blacklist notification will be within a few minutes of the offending message delivery attempt, and will be during the life of the relevant SMTP session. Your action now should depend on the nature of the IP address above: 1. End-user system with dynamically allocated IP address: Identify which user was using the IP address at that time. Probably the user has a virus infection, open proxy, or other computer security problem. You should notify the user, giving your usual antivirus/security advice. We understand that the information we have provided above will probably not be specific enough for you to take Terms Of Service action against the user, or to completely resolve the issue. However, since we do not keep the junk mail we will be unable to provide more information. This notification is a courtesy, and to allow you to warn your user and/or take other investigative steps. There is no harm in a dynamically-assigned end-user IP address being blacklisted as an SMTP sender, so the blacklist entry can stand. 2. One of your designated outbound mail servers: Use the timestamp information above to find the mail transaction in your logs. You will then be able to identify the source of the junk mail and take appropriate action. If your system has very high mail volumes then you may need to contact us for further information - see below. If the blacklisting entry turns out to be a mistake we will of course unblacklist you. However, we do not unblacklist systems which have genuinely sent junk mail, except in response to an end user request. 3. A system with fixed IP address which should not be sending mail: The system is misconfigured and should be secured so that it cannot be abused by spammers or viruses. The blacklist entry can and should stand. There is usually no need to contact us about this blacklist entry. If you feel the need to write to us, please read the following common questions and answers, first. If you send us a message which is covered by one or more of the following answers, we will simply ignore it. This includes automated replies, or semiautomated form letters. Q. Please provide full headers of the junk mail. A. We do not keep the headers or texts of the junk mails. You should be able to identify the message or user in question from your logs. Q. We do not keep our logs that long, so cannot identify the source of the junk mail. A. As a participant in the Internet, we feel it is your responsibility to keep such logs, for a few weeks at least. If you choose not to do this for operational (ie financial) reasons then you must accept the consequences, which include being blacklisted for sending junk mail. Q. We have too high a mail volume to identify the transaction from only the timestamp. A. Please contact us, as directed below, and we will supply some additional information about the offending mail. We will usually be able to supply the recipient domain name and recipient host, at our end, and in some cases we can supply the envelope sender or part of it. We may also be able to provide a specific timestamp of the offending RCPT or DATA command. Q. We run only confirmed opt-in lists. Q. Tell us the email address you want removed. A. Based on our logs, we are sure that the email address you mailed to could not have participated in an opt-in confirmation. We are therefore sure that your list is not confirmed opt-in. To stop spamming, you must throw away that list completely. If you bought it from someone, you should consider legal action against them. We will not tell you the bait email address, because that would allow spammers such as yourself to `launder' the list of bait addresses, decreasing the effectiveness of our antispam measures while allowing you to continue to use the spamlist. Q. How dare you blacklist us without showing us proof ! A. We recognise that the information we have provided will not necessarily be convincing to you, or to a third party. Nevertheless, it (and other information that we are not prepared to reveal, such as the recipient bait address) is convincing to us, and it is our choice who we put on our blacklist. Q. Please resend your report (and/or please direct future messages) to abuse@example.com instead. A. Our system determines the email address to report to automatically by querying the DNS and using the only local-part (`postmaster') that the RFCs mandate *must* exist. We do not keep a database of sites and corresponding abuse addresses, as we do not wish to incur the expense of maintaining one. A WHOIS query might yield a different address, but automated use of WHOIS in this way might easily be considered abuse. It is therefore not possible for us to mail to a different address. Please forward the notification to the appropriate part of your organisation, yourself. If this is not convenient then you may of course ignore the blacklist notification. If you object to the notifications and wish us to ensure that you do not receive any in the future, please notify us - using the contact information below - of all of your IP address ranges. We will then arrange to block all email from your systems, and there will be no need to send you any blacklist notifications. Q. It was an open relay and has been fixed. Q. We had a virus but have cleaned it out and improved our security. Q. We have warned/terminated the user. Q. We are a large ISP and our many users will be blocked. Q. We have strong abuse policies, and this is an isolated incident. ... so please unblacklist us. A. It is our policy to blacklist any sending site (by IP address) which sends our systems junk mail (including spam and viruses) and which does not have, at that time, an established email flow to us. In most cases we do this entirely automatically. We keep such blacklist entries until they expire, or until a need arises for an end-user of a blacklisted mail relay to contact one of our users. When such an end-user's mail is rejected with a `blacklisted site' message, we hope that they will contact their or our postmaster (postmaster mail bypasses the blacklist) and we will then remove the blacklist entry. We do *not* remove blacklist entries just because the original problem, which opened the flow of junkmail from the blacklisted site, has been fixed. We feel that an organisation which has made configuration errors allowing their systems to be abused for junk mail, or whose customers or users did so, is quite likely to make a similar mistake in future; this is much more probable than that they actually need to mail one of our users. Therefore we feel that unblacklisting because the affected site claims the problem was found and fixed is not beneficial to our users. Likewise, we do not remove blacklist entries merely because of the size of the offending site. It is not to our users' benefit to unblacklist large sites with many users, some of whom send junk to us, but none of whom currently want to talk to our users. Note that although in order to have a 0% collateral damage rate from our blacklist, you would have to have a 0% junkmail rate, that does not mean that we demand that you run our site in a way that completely eliminates all junkmail sent or relayed by it to the rest of the Internet. We merely ensure, via our software and policies, that not all of the costs to us of junkmail from your site are borne by us and our users - instead, we return some of those costs to you in the form of blacklisting and hassle. Many other sites on the Internet operate similar (or even harsher!) policies to ours, but most do not notify site administrators of blacklistings. You may find that your users will, after this junk mail problem, encounter a somewhat greater rate of mail difficulties with other sites besides ours. If you find these costs unacceptable we recommend that (in the case where your users or partner organisations are the root cause) you institute stronger local policies that allow you to recover your costs from those more directly responsible, or that (in the the case of errors on your part) you acquire more expertise to avoid mistakes in the future. We hope this explanation has been clear and helpful, and has not caused offence. If you have further questions please mail us again. Q. What is a `spambait address' ? A. A spambait address is one which is published in newsgroups, web pages, etc., in a way that will encourage automated address harvesters to pick it up, but with context which clearly discourages the human reader from using the address. Whenever our system receives a mail for a bait address it automatically blacklists the sender. Q. I would like to contact you. A. Certainly. Please read the Q-and-A above, and if your question is still not answered then you should contact us using the address `sauce-admin' at the hostname above. Ie, replace `sauce-daemon' with `sauce-admin'. That will bypass the blacklist. Do not reply directly to this message, to `sauce-daemon', as such mail is blocked or ignored. -- work/clean-site-annoy.in0000775000000000000000000000117415116102070012425 0ustar #!/bin/sh # WARNING - DO NOT RUN THIS SCRIPT WITH SAUCE RUNNING! # This script fixes the mess left by the site-annoy huge expiry time # bug, by deleting all entries that have implausible timeouts. set -e cd ${@@@var_dir@@@} time_t=$(date '+%s') if test $time_t -ge 1300000000 then cat >&2 <<'END' clean-site-annoy is being run _FAR_ too late. Please consult sauce-maint. Alternatively, simply deleting your site-annoy database is reasonably safe. END exit 1 fi for f in main log; do w=db.site-annoy.$f test -f $w || continue egrep -v ' 1[^0-4]| 2' $w >$w.new || test $? = 1 rm -f $w.csa~ ln $w $w.csa~ mv -f $w.new $w done work/config0000664000000000000000000000363015116102070010113 0ustar blacklist_message "You are blacklisted - see http://www.chiark.greenend.org.uk/spamtrap/" blacksite_message "Your site is blacklisted - see http://www.chiark.greenend.org.uk/spamtrap/" addr_whitelist_delay 5m addr_whitelist_timeout 15m addr_verified_timeout 8m addr_blacklist_timeout 10m site_whitelist_delay 4m site_whitelist_timeout 14m site_verified_timeout 7m site_blacklist_timeout 9m new_addr_defer 30s new_site_defer 1m #rbl rbl.test.iwj.relativity.greenend.org.uk 20s 20s "(%m) (%d) (%p)" rbl rbl.test.iwj.relativity.greenend.org.uk 20s 20s #rbl rbl.test.iwj.relativity.greenend.org.uk reject remember_addr_defer 1d remember_site_defer 1d local_domain davenant.greenend.org.uk local_interface 172.18.45.2 local_interface 127.0.0.1 var_dir . config_dir . port 8430 addr_patterns_nodefault addr_regexp .* policy addr_regexp ([a-z]+)@ user addr_regexp ([a-z]+)@davenant\.greenend\.org\.uk user addr_regexp ([a-z]+)\+.*@ user addr_regexp 0([a-z]+)k.*@ user addr_regexp (.*)@pick\.ucam\.org user=matthewv: addr_pattern unchecked sauce-admin@ addr_pattern unchecked postmaster@ addr_pattern bait bait@ addr_pattern nodelay nodelay@ verify_perconn_timeout 60s verify_cache_timeout 6s verify_reuse_timeout 12s verify_rset_timeout 12s admin_secret_refresh 5m always_blacklist_site true allow_saucestate true busyfury_firewall false command_timeout 15s force_shutdown_delay 5s anger_stallwith "You wouldn't like me when I'm angry." annoy_halflife 10m annoy_grudge_max 1m annoy_love_max 1m annoy_actout_max 15s annoy_actout_nopartresp 5s annoy_grumpy 5s annoy_partrespevery 2s pleasure_command 1s pleasure_delivery 5s annoyance_minor 1s annoyance_major 5s debug_level 3 log_stderr true check_helo_name true #ipaddr_phase_proportion 100 irritated_tell_submissive Oh, master! taboo_virus_hack 1 work/convertdb.in0000775000000000000000000000375615116102070011255 0ustar #! /usr/bin/tclsh # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: convertdb.in,v 1.3 2006/04/02 18:30:36 ian Exp $ load chiark_tcl_cdb-1.so if {[llength $argv] < 2} { error "usage .../convertdb outfile timeadj infiles..." } set outfn [lindex $argv 0] set timeadj [lindex $argv 1] proc on_info {args} { puts [concat on_info $args] } if {[file exists $outfn]} { error "wrong argument order" } cdb-wr create-empty $outfn set out [cdb-wr open $outfn on_info] cdb-wr compact-explicit $out foreach infn [lrange $argv 2 end] { set in [open $infn r] puts "reading $infn" fconfigure $in -translation lf -encoding binary set lno 0 while {[gets $in l] >= 0} { incr lno if {![regexp {^\:.*\;$} $l]} { puts stderr "warning: $infn:$l: incomplete record" continue } if {![regexp {^\:([^ ]+) ([^{}\\]+)\;} $l dummy key value]} { error "error: $infn:$l: bad record" } if {[string length $timeadj]} { set newvalue {} foreach {time eachvalue} $value { incr time $timeadj set time [format 0x%016x $time] set newvalue [lreplace $newvalue 0 -1 $time $eachvalue] } set value $newvalue } cdb-wr update $out $key $value } } puts "finalising" cdb-wr compact-force $out puts "closing" cdb-wr close $out work/datastate.tcl0000664000000000000000000001267015116102070011405 0ustar ########## datastate.tcl # This file contains core routines for handling the persistent # data with timeouts. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: datastate.tcl,v 1.15 2006/04/03 01:02:07 ian Exp $ # This routine maintains permanent database(s) of information about # key(s). Each database maps a key to a state value. The state # values are defined by the caller. The states may time out, and be # replaced by other states, as defined by the caller. # We use a cdb-wr from chiark-tcl. Keys are the key as supplied to # ds_set (possibly quoted if specified during bind). # Values are of the form # 0xHHHHHHHHHHHHHHHH ultimate-value 0xHHHHHHHHHHHHHHHH penultimate-value... # ... 0xHHHHHHHHHHHHHHHH current-value # The variables used internally are: # ds__cdbwr.DB cdb-wr handle # ds__perm.DB.(KEY) Permanent settings (VALUE only) # ds__quotekey.DB 0 or 1 # ds__regexp.DB Regexp which values must match load chiark_tcl_cdb-1.so #---------- general utilities ---------- proc ds__proctimeouts {db telemvar now} { upvar 1 $telemvar telem set changed 0 debug 4 ds__proctimeouts $db at $now $telem ... while {[llength $telem] && [lindex $telem end-1] < $now} { set telem [lrange $telem 0 end-2] set changed 1 } debug 3 ds__proctimeouts $db at $now $telem ! return $changed } proc ds__setentry {db key telem} { upvar #0 ds__cdbwr.$db cdb if {[llength $telem]} { debug 3 ds__setentry $db $key := $telem cdb-wr update $cdb $key $telem } else { debug 3 ds__setentry $db $key :=<> cdb-wr delete $cdb $key } } proc ds__checkvalue {db value} { upvar #0 ds__regexp.$db regexp if {![regexp -- $regexp $value]} { error "bad db value $value for $db" } } proc ds__key_quote {key} { set keyquoted {} while {[regexp -nocase {^([-=_+@.%0-9a-z]*)([^-=_+@.%0-9a-z])(.*)$} \ $key dummy l ch key]} { binary scan $ch H* hex append keyquoted $l {\x} $hex } append keyquoted $key return $keyquoted } proc ds__key_quote_maybe {db keyvar} { upvar #0 ds__quotekey.$db doquote if {!$doquote} return upvar 1 $keyvar key set key [ds__key_quote $key] } #---------- retrieval ---------- proc ds_get {db key} { # Returns the current value in DB of KEY. If the key is not # found (or has expired), returns `unknown'. ds__key_quote_maybe $db key upvar #0 ds__perm.$db.($key) perm upvar #0 ds__cdbwr.$db cdb if {[info exists perm]} { debug 2 ds_get $db $key ?.=> $perm return $perm } set telem [cdb-wr lookup $cdb $key {}] if {[ds__proctimeouts $db telem [clock seconds]]} { ds__setentry $db $key $telem } if {[llength $telem]} { set value [lindex $telem end] ds__checkvalue $db $value debug 2 ds_get $db $key ?=> $value } else { set value unknown debug 2 ds_get $db $key ?=>- $value } return $value } #---------- updating ---------- proc ds_set {db key args} { # Sets, in DB, the value of KEY. The remaining ARGS should come # in pairs VALUE TIMEOUT, where VALUE is the value, and TIMEOUT is # the duration in seconds for which the value should hold. VALUEs # should consist of alphanumerics. ds__key_quote_maybe $db key upvar #0 ds__perm.$db.($key) perm set now [clock seconds] if {[info exists perm]} { debug 2 ds_set $db $key (:=$args) .= $perm return } debug 2 ds_set $db at $now $key := $args set telem {} foreach {value timeout} $args { ds__checkvalue $db $value incr timeout $now set telem [lreplace $telem 0 -1 [format 0x%016x $timeout] $value] } ds__proctimeouts $db telem $now ds__setentry $db $key $telem } proc ds_setforever {db key value} { # Sets, in DB, the value of KEY to VALUE, forever. This is not # recorded in any database files - it is assumed to be the # result of static configuration. ds__key_quote_maybe $db key upvar #0 ds__perm.$db.($key) perm debug 2 ds_setforever $db $key :=. $value ds__checkvalue $db $value set perm $value } #---------- binding and machinery ---------- proc ds__oninfo {db args} { log notice "$db cdb-wr $args" } proc ds__clockseconds {} { format 0x%016x [clock seconds] } proc ds_bind {db prefix regexp quotekey} { # Binds the database DB to files with prefix FILEPREFIX. # This will load the database, and it will also cause # updates to be recorded there. FILEPREFIX is passed to cdb-wr. # Values must match REGEXP (though ds_get may also return `unknown'). set now [clock seconds] debug 3 ds_bind $db $prefix at $now upvar #0 ds__cdbwr.$db cdb foreach v {regexp quotekey} { upvar #0 ds__${v}.$db toset set toset [set $v] } set cdb [cdb-wr open $prefix [list ds__oninfo $db] ds__clockseconds] } work/db.manual0000664000000000000000000000002515116102070010502 0ustar site white 127.0.0.1 work/debian/0000775000000000000000000000000015116102070010143 5ustar work/debian/changelog0000664000000000000000000006204215116102070012021 0ustar sauce (0.9.6) unstable; urgency=medium [Ben Harris] * Add Salsa CI config based on userv's one * Add a systemd unit file. Closes: #1039361. Don't use sauce-startup.log. * Remove explicit invocations of update-rc.d from maint scripts * Add dh_clean to "clean" target * Use ${misc:Pre-Depends} and ${misc:Depends} [Ian Jackson] * init script: Source lsb/init-functions.. [Suggestion from Ben Harris] * Add a debhelper dropping to .gitignore. * Break out sauce-await-startup and use it in service file and init script. * init script: Honour $SAUCE_USER on stop. * Provide SAUCE_USER default in example sys-config. [Report from Ben Harris] * autopkgtest: Test a restart. -- Ian Jackson Tue, 09 Dec 2025 20:19:04 +0000 sauce (0.9.5) unstable; urgency=medium * Debian: Use debhelper for various operations, notably dh_installdeb and dh_installinit. -- Ian Jackson Sun, 07 Dec 2025 22:40:36 +0000 sauce (0.9.4) unstable; urgency=medium * Completely rework adminsecret handling * Startup script: Pass -s to su * init script: Wait for sauce to have started. * Add an autopkgtest -- Ian Jackson Fri, 14 Nov 2025 18:41:31 +0000 sauce (0.9.3) unstable; urgency=medium * When verifying email addresses, tolerate MX's that have only AAAA RRs and no A RRs. (We still don't properly support IPv6, sadly.) [Report from Simon Iremonger] Closes: #1106228. -- Ian Jackson Sat, 24 May 2025 19:57:55 +0100 sauce (0.9.2+nmu1) unstable; urgency=medium * Non-maintainer upload. * Be explicit about the need for `fakeroot` for assembling the binary packages via `Rules-Requires-Root: binary-targets`. (Closes: #1086944) -- Niels Thykier Mon, 30 Dec 2024 10:10:45 +0000 sauce (0.9.2) unstable; urgency=medium * debian/rules: Fix mode on /etc/logrotate.d/sauce. (Existing installations won't be fixed; the mode can be changed to 0644 by the administrator.) loses: #1035361. [Report from Andreas Beckmann] * sauce9-convert.in: Change chown call to use new : syntax. (Closes: #1035396. [Report from Andreas Beckmann] * debian/rules: Change chown call to use new : syntax. -- Ian Jackson Sun, 14 May 2023 17:50:33 +0100 sauce (0.9.1) unstable; urgency=medium [ Ian Jackson ] * Restore .cvsignore file erroneously deleted in NMU * Rename .cvsignore to .gitignore * debian/control: Update Maintainer address (Closes: #979639) [ Chris Lamb ] * debian/rules: Make the build reproducible (Closes: #777401) -- Ian Jackson Wed, 27 Jan 2021 16:54:09 +0000 sauce (0.9.0+nmu4) unstable; urgency=medium * Non maintainer upload by the Reproducible Builds team. * No source change upload to rebuild on buildd with .buildinfo files. -- Holger Levsen Sat, 09 Jan 2021 17:29:06 +0100 sauce (0.9.0+nmu3) unstable; urgency=low * Non-maintainer upload. * Change Tcl dependencies to tcl instead of obsolete tcl8.4. Closes: #725278. * Adjust working with masks to Tcl 8.5 and newer arbitrary precision integers. Closes: #655733. -- Sergei Golovan Thu, 31 Oct 2013 14:41:24 +0400 sauce (0.9.0+nmu2) unstable; urgency=low * Non-maintainer upload. * Fix "Depends on Tcl 8.3 which is planned to removal" Applied patch by Sergei Golovan (Closes: #473014): - Changed Tcl dependencies to tcl8.4 instead of obsolote tcl8.3 -- Bastian Venthur Fri, 13 Aug 2010 23:42:21 +0200 sauce (0.9.0+nmu1) unstable; urgency=low * Non-maintainer upload. * Remove code from postinst that creates a link to /usr/doc/sauce, if /usr/doc exists. (Closes: #359574) * libadns1-bin has been renamed to adns-tools, update dependency. (Closes: #490764) * Semantically fix broken changelog entry for 0.8.2. (Closes: #497715), please note that the actual date I set is not correct, as I couldn't find that upload. * Remove copyright notice at the end of debian/changelog. (Closes: #499685) -- Holger Levsen Sun, 21 Sep 2008 10:31:29 +0000 sauce (0.9.0) unstable; urgency=low Improvements: * Treat 55x on banner as permanent address verification failure, as suggested by Ben Harris. Closes: #443512. Bugfixes: * Timeout for message body reception, which was previously missing (!) * Timeout for transmission of delayed responses. * Cleanups from chiark: fix some leaked channels and timeouts. * Always call ic_msg_resetvars after ic_*command*response*. Debian packaging fixes, and portability improvements: * Replace test == with test =. Closes: #465356. * Specify SHELL=/bin/bash in debian/rules. Closes: #459125. * LSB init script dependencies specified. Closes: #469630. While we're there, remove the rcsid and attribution stuff, which will just cause needless conffile prompts etc. * Use invoke-rc.d in Debian maintainer scripts. * Slight reorganisation of {binary,build}{-arch,-indep,} rules. * Use logrotate instead of savelog. * Increased Standards-Version. Closes: #346056. * Add exim4 to recommendations for suitable MTA. Closes: #228574. * Change maintainer email address. -- Ian Jackson Sat, 08 Mar 2008 17:35:10 +0000 sauce (0.8.99.iwj.5) unstable; urgency=low Improvements: * Better messages reporting various avf failures, particularly timeouts and unexpected SMTP responses. * Rewrite stupid Outlook-generated syntax error To header, leaving a warning in the headers if we accept. -- Ian Jackson Sat, 28 Oct 2006 18:00:39 +0100 sauce (0.8.99.iwj.4) unstable; urgency=low * Bugfixes from chiark: Correct oninfo handler for cdb-wr. Do not treat every to-be-quoted key as the string `key' (!) -- Ian Jackson Mon, 3 Apr 2006 02:01:56 +0100 sauce (0.8.99.iwj.3) unstable; urgency=low * adns done with chiark_tcl_adns extension rather than fork/exec adnshost. Ready for test on chiark. -- Ian Jackson Mon, 3 Apr 2006 01:57:01 +0100 sauce (0.8.99.iwj.2) unstable; urgency=low * convertdb, sauce9-convert, etc., seem to work * use cdb-wr from chiark-tcl instead of Tcl hashes. 30x less RAM used. * new convertb script, wip * smtp.tcl sets encoding conversion MUST CHECK OTHER CHANNELS, LOGS changes from chiark: * properly clear out various variables in ic_msg_resetvars. * new config paramater blmessage_sendmail_args * allow disabling of blacklist notifications if message is /dev/null * punish sites that send bogus ident replies * check whitelisted sites for RBL, too * copyright notices for convertdb and sauce9-convert convertdb -> convertdb.in * make files in /var/lib/sauce 0644 mail.mail. * do not treat every email address as `key' (!) -- Ian Jackson Sun, 2 Apr 2006 20:07:13 +0100 sauce (0.8.2) unstable; urgency=high * Do not 421 when PIPELINING disappears from the ESMTP extensions we want to offer. Instead, just offer it again anyway. * Actually install stall.tcl (!) * TODO list says we should check dates. * Make cron.weekly refer to SAUCE_LOGS_... like in sys-config, not SAUCE_LOG_... -- Ian Jackson Sat, 2 Apr 2005 20:07:13 +0100 sauce (0.8.1) unstable; urgency=low Bugfixes: * site-annoy database expires properly (NB you must clean it when you upgrade!) * Fix descriptor leak in ic msg_checkeof. * More sensible debug.log entries for firewall commands. * Display ipchains/iptables commands in debug.log. New features: * Support Linux 2.4 iptables. * Sobig.F shibboleth implemented (taboo_virus_hack, default=off). * New X-SAUCE-Notice header informs receiving user of anger towards sending site. * busyfury_firewall has new value `immed' meaning firewall for every `421 too busy' or `421 excessive concurrency', not just when maximally furious. * New `errok-' policy option for stopping SAUCE from getting too upset with .forward-upstreams and mailing list hosts. Untested yet. * Stalling pure-teergrube server for over-aggressive callers. * Reinvoking thread_typedefine made safe: doesn't reset id counter. (Means you can patch the running SAUCE more easily.) Changes to autoblacklisting: * blmessage.text split into blmessage-site.text and -addr.text. * blmessage.text updated from chiark (no unblacklist policy). * Update blacklist timeouts. (2mth/2mth -> 7d/12mth) -- Ian Jackson Wed, 14 Jan 2004 23:48:01 +0000 sauce (0.7.14) unstable; urgency=low Build changes: * Now uses Tcl 8.3 (there are no code changes, so 8.2 should still work). Closes: #183804. * debian/control has build dependency on tcl8.3. Closes: #190520. Administrative changes: * Copyright notices updated. * Blurb slightly improved; ref. to MAPS removed. * README now says it's BETA. -- Ian Jackson Sun, 15 Jun 2003 16:46:43 +0100 sauce (0.7.13) unstable; urgency=HIGH Bugfixes: * Do not blacklist on bounces, by default. * Do not complain about lack of Resent-Message-ID when not required. * When refreshing site blacklist, actually put in site, not addr, db. * When we quit the MTA, turn blocking on (avoids fd leak Tcl bug). -- Ian Jackson Sun, 15 Jun 2003 16:30:55 +0100 sauce (0.7.12) unstable; urgency=HIGH * thread.tcl spurious word `sauce' in log message changed. * fix erroneous rejection regarding Resent- headers. -- Ian Jackson Sun, 10 Nov 2002 17:44:59 +0000 sauce (0.7.11) unstable; urgency=medium Fixes to general bugs and other infelicities: * Actually do avf on originator headers (!) * When underlying MTA dies at banner or HELO, say that it's the MTA's failure message we display. * Dependency on exim allows exim-tls too. * When firewall setting fails, do not bomb out completely. * Include ic id in saucestate response. * Edited TODO. Occasional `421 Internal error' bugs fixed: * On DATA because we didn't spot mixed recipient kinds. * At final dot. (Propagate `eom' through header processing.) * ip-literal originator headers. (Pass and hexify [ and ].) * On DATA with no recipients (initialise a_kinds and other variables.) * When pipelining avf gets unexpected eof. -- Ian Jackson Fri, 5 Jul 2002 19:08:17 +0100 sauce (0.7.10) unstable; urgency=low * sauce-setuserpolicy userv service works with subpolicies. -- Ian Jackson Tue, 4 Dec 2001 19:37:26 +0000 sauce (0.7.9) unstable; urgency=low * Default verification timeouts tweaked. * When doing maildomain lookup, allow partially-cropped names to be CNAMEs, but do not allow original HELO name to be CNAME. -- Ian Jackson Sun, 18 Nov 2001 15:41:10 +0000 sauce (0.7.7.1) unstable; urgency=low NMU changes: * moved docs from /usr/doc to /usr/share/doc (closes: #91644), also edited postinst and prerm to handle /usr/doc/sauce link correctly * Corrected location of GPL file. * Corrected spelling error in description. * Set documentation file permissions to 0644 (was 0755). Additional NMU changes: * update-rc.d output goes to /dev/null. * dpkg-gencontrol passed the -isp option. -- Bas Zoetekouw Fri, 3 Aug 2001 11:38:39 +0200 sauce (0.7.7) unstable; urgency=high Important new features and improvements: * SAUCE now does not normally reject until it sees RCPT. This makes it possible to mix SAUCEd and effectively un-SAUCEd addresses at the same domain. * Policy strictness, and the delay feature, are now much more configurable, and the possible recipient classes have been improved, clarified and documented. The configuration can be per recipient address, including taking into account the local-part, as well as details of the sending site or user. Policy can be configured by users using userv. * Rejection log entries are much improved. They now nearly always include: - the sending site name (or address) and envelope sender; - the recipient(s), and the SMTP response code given to each; - any RBL domains hit, as a separate item; - all the reasons why the rejection or deferral happened. * Now we try to be generous at `accepting' mails to bait addresses. We return 250, but throw the message away. * For mails we'd like to reject, but policy says to accept, we add an X-SAUCE-Warning to the headers saying what was wrong. Minor improvements and new features: * Count avf MAIL FROM:<> => 5xx as a definite failure. * Irritation amount strings as displayed in SMTP responses are configurable. * When stalling due to anger (teergrube), fill up with anger_stallwith messages, not repeats. These messages are configurable. * Transaction IDs are improved and appear in some visible outputs. * configurable notifybl from, default sauce-bounces@canonical_hostname. * When doing recipient verifications, we pause before accepting most of the header, rather than at final dot. This may slightly reduce message duplication under pathological conditions. * Default blmessage.text simplified and now uses 1st person plural. * Debug messages are now indended by procedure call level. * Default set-firewall script included. * Internal syntax changes and cleanups. Many bugfixes: * If avf fails (except for 5xx), try again on a fresh connection. * Debian init.d stop script uses start-stop-daemon to ensure death. * When we shut down, catch_close_cleardesc the mtachan to abort any teergrube output currently happening. * Don't let the SMTP thread hang around after caller goes away. * Properly kill subthreads in when we finish an SMTP thread. * Originator header syntax checking uses its own errorCode to avoid 550 due to internal errors. * Copyright dates updated. * Assorted other bugfixes. Debian packaging changes: * Now `extra' rather than `experimental'. * Depends on libadns1-bin. * Maintainer address corrected. (Version numbers 0.7.0-0.7.5 are on the branch-2000-12-21-overhaul, where the code should be considered ALPHA; this change log lists only changes that are relevant compared to the state in 0.6.1.) -- Ian Jackson Wed, 21 Mar 2001 23:59:54 +0000 sauce (0.6.1) unstable; urgency=low Bugfixes from chiark: * Cope with new format of ipchains -L output. * dbreasons log is more important than reject log. * --unknown option added to sauce-bwlist. * Allow HELO name to be CNAME (why?). * If HELO DNS lookup gives MISCONFIG, print correct error message. * Always print postmaster@... address in HELO response. * If RBL gave unexpected answer, preserve flow of control. -- Ian Jackson Sun, 20 Aug 2000 17:50:21 +0100 sauce (0.6.0) unstable; urgency=medium Major improvement: * Now uses adnshost(1) instead of host(1) for DNS lookups. (`host' is from BIND and is buggy.) This will produce some stricter checks. Bugfixes from chiark: * When ident gives garbage, do not lose thread flow-of-control. * RCPT arguments containing { } (and other metacharacters) properly processed rather than causing internal error. * userblacklist now -bwlist, can whitelist too. -- Ian Jackson Wed, 10 May 2000 01:51:41 +0100 sauce (0.5.0) experimental; urgency=low * New documentation files {README,BLURB,ERRORS,INSTALL}.text. * Give `install' the `-c' flag (and not `-o root -g root'). -- Ian Jackson Sun, 17 Oct 1999 19:57:34 +0100 sauce (0.4.14) unstable; urgency=low * Split sauce.tcl into two parts; have goes into new smtp.tcl. -- Ian Jackson Sat, 9 Oct 1999 16:48:20 +0100 sauce (0.4.13) unstable; urgency=medium New features: * Limit number of connections (prefer sites we're pleased with). * Firewall out sites which make us very angry and exceed conn limit. -- Ian Jackson Sat, 9 Oct 1999 15:58:47 +0100 sauce (0.4.12) unstable; urgency=medium Bugfixes: * When databases have bad format, show the line in question. * Blank commands, read errors, & unexpected EOFs reported sensibly. * Send blacklist notifications from <>. * Do not become angry (or pleased) with any local interface. * New `Ecstatic' pleasure level. * Show anger/pleasure in greeting. * Avoid unset variable bug with state(mf_parms). -- Ian Jackson Sat, 18 Sep 1999 18:00:10 +0100 sauce (0.4.11) unstable; urgency=low Bugfixes: * Properly store and remember quoted datastate keys. -- Ian Jackson Sun, 12 Sep 1999 23:15:16 +0100 sauce (0.4.10) unstable; urgency=low Bugfixes: * Do not listen to input after timeout-disconnect. -- Ian Jackson Sun, 12 Sep 1999 22:28:59 +0100 sauce (0.4.9) unstable; urgency=low Bugfixes: * Greeting doesn't count as a minor fault any more. -- Ian Jackson Sun, 12 Sep 1999 21:24:21 +0100 sauce (0.4.8) unstable; urgency=low Bugfixes: * Show sending hostname in acceptance messages. -- Ian Jackson Sun, 12 Sep 1999 20:29:29 +0100 sauce (0.4.7) unstable; urgency=low Bugfixes: * Defer really counts as a minor fault. Greeting, too. -- Ian Jackson Sun, 12 Sep 1999 20:05:40 +0100 sauce (0.4.6) unstable; urgency=low Bugfixes: * More improvements to irritation logging. -- Ian Jackson Sun, 12 Sep 1999 19:34:03 +0100 sauce (0.4.5) unstable; urgency=low Bugfixes: * When irritated, log the causes. -- Ian Jackson Sun, 12 Sep 1999 19:00:51 +0100 sauce (0.4.4) unstable; urgency=low Bugfixes: * Do not go into infinite recursing when shutting down ! -- Ian Jackson Sun, 12 Sep 1999 18:44:24 +0100 sauce (0.4.3) unstable; urgency=low Bugfixes: * Remove rcsid line from /etc/sauce/sys-config. * Proper timing of annoyed messages (no long gap at end of delays). * Properly encode anger values in datastate. -- Ian Jackson Sun, 12 Sep 1999 18:32:01 +0100 sauce (0.4.0) unstable; urgency=medium New features/improvements: * sauce-blacklist => sauce-bwlist, and can now whitelist too. * SAUCE now gets "angry" with sites sending lots of bogus stuff. Bugfixes: * Allow CNAMEs to point to non-hostnames (needed for classless in-addr). * Copyright notices and dates updated. * Now uses tcl 8.2. -- Ian Jackson Sun, 12 Sep 1999 17:25:30 +0100 sauce (0.3.6) unstable; urgency=low Bugfixes: * Check for missing config settings works (thanks Dan Sheppard). * Don't produce dbreasons log entry if new state is same as old. * Don't spout silly `mfok' debugging to stderr. -- Ian Jackson Sat, 21 Aug 1999 03:51:23 +0100 sauce (0.3.5) unstable; urgency=medium New features/improvements: * Extra quitting check when actually issuing responses. * New ds state for addr 'verified' to save on avf's for bypass. * Changed defaults for various things to match chiark's config. Bugfixes: * Allow blacklisted senders/sites to contact admins, as intended ! * Be case-insensitive about domain names in addr_classify. * Make admin addresses avoid header checks like bypass addrs. -- Ian Jackson Thu, 12 Aug 1999 00:42:52 +0100 sauce (0.3.4) unstable; urgency=medium Bugfixes: * Allow CNAMEs with strange data (sigh). * Don't put deferrals in the reject.log. * Lowercase the domain in addr_classify. * Apply teergrube delay to closing message `421 ... some error ...'. * Include domain in listing of bait addresses in dbreasons.log. * Use fconfigure -translation binary to avoid crazyness on CR-CR-LF. * Put dates and exit status in the sauce-startup.log, and append. -- Ian Jackson Thu, 29 Jul 1999 02:46:47 +0100 sauce (0.3.3) unstable; urgency=high * Make socket translation mode be {binary crlf} throughout; and strip CRs ourselves in threadio_gets. -- Ian Jackson Mon, 19 Jul 1999 22:05:27 +0100 sauce (0.3.2) unstable; urgency=low * Better error messages for connection and verification failure. * Make userblacklist work again. * Make RSET on verify connection work properly. * Make error handling cleanup for avfpool crash be complete. * ipaddr_phase_proportion requires local_interfaces to avoid inability to use sauceadmin. -- Ian Jackson Thu, 15 Jul 1999 03:08:49 +0100 sauce (0.3.1) unstable; urgency=low * sauceadmin shutdown waits for the shutdown to happen. * Bugfixes. -- Ian Jackson Sun, 4 Jul 1999 21:01:48 +0100 sauce (0.3.0) unstable; urgency=high Major overhaul: * Redone persistent database handling. * No more pause after final dot. * Bugfixes and other changes. * VRFY implemented. * Add Received header. * RBL support. -- Ian Jackson Sun, 4 Jul 1999 20:25:06 +0100 sauce (0.2.13) unstable; urgency=low More bugfixes and features from chiark, including: * userblacklist support. * reject.log. * Accept source-routes in addresses in MAIL FROM and RCPT TO. * Make require_messageid configurable (default=true). * Missing `quit' causes no peeved 421 message. * Attempt to set -oMr to include -sauce. * Do not advertising PIPELINING. * Advertise X-SAUCE (temporary?) * show and help moved to yesmaster. * Default *_whitelist_delay increased to 5d from 1d. -- Ian Jackson Wed, 16 Jun 1999 23:21:44 +0100 sauce (0.2.11) unstable; urgency=low More bugfixes and features from chiark, including: * Logging of rejection after body transfer in notice log. * Teergrube. * Limit number of SMTP errors. * Logging of connection close (421) messages in notice log. * More diagnostics to far end if MTA fails on banner or hello. * More info about which threads were around if shutdown times out. -- Ian Jackson Thu, 3 Jun 1999 02:56:41 +0100 sauce (0.2.10) unstable; urgency=low * Bugfixes from chiark. -- Ian Jackson Mon, 24 May 1999 20:57:57 +0100 sauce (0.2.9) unstable; urgency=low * Default bait address patterns really fixed. -- Ian Jackson Sun, 25 Apr 1999 19:39:42 +0100 sauce (0.2.8) unstable; urgency=low * Default bait address patterns fixed. -- Ian Jackson Wed, 21 Apr 1999 23:30:10 +0100 sauce (0.2.7) unstable; urgency=low * DNS threads now distinguish nonexistent domains and no RR of requested type; this improves error messages. * DNS RR syntax (as out of `host') is now checked. * standard output and standard error from host is now distinguished - no more misunderstanding error messages as RRs. * `record currently not present' message from host is now treated as permanent error meaning no RR of requested type; this is right unless the local nameserver is misconfigured. host does not appear to properly distinguish real permanent errors here from transient ones. * If Tcl were not broken then a nonzero exit status from host would prevent successful answers from coming back from DNS queries. -- Ian Jackson Sun, 13 Sep 1998 23:29:18 +0100 sauce (0.2.6) unstable; urgency=low * Several bugfixes, and new timeout beyond which shutdown is forced. -- Ian Jackson Thu, 10 Sep 1998 01:53:08 +0100 sauce (0.2.5) unstable; urgency=low * Report errors properly in thread_sysshutdown. -- Ian Jackson Thu, 3 Sep 1998 11:30:54 +0100 sauce (0.2.4) unstable; urgency=low * Do not die if ident unavailable. * Debug level 2 gives sendmail command line args. -- Ian Jackson Thu, 3 Sep 1998 11:22:43 +0100 sauce (0.2.3) unstable; urgency=low * Add config-info.text. * Don't make unkillable daemon if many are started. * If msg_origverify gives error, do not get Tcl error. -- Ian Jackson Wed, 2 Sep 1998 19:38:03 +0100 sauce (0.2.2) unstable; urgency=low * Various minor fixes, proper version number. -- Ian Jackson Wed, 2 Sep 1998 18:11:18 +0100 sauce (0.2.1) experimental; urgency=low * First version with source package, proper maintainer scripts. -- Ian Jackson Wed, 2 Sep 1998 17:56:02 +0100 sauce (0.2) unstable; urgency=low * Many improvements. -- Ian Jackson Wed, 2 Sep 1998 15:28:37 +0100 sauce (0.1-1) experimental; urgency=low * Initial release. -- Ian Jackson Sat, 29 Aug 1998 14:57:50 +0100 work/debian/conffiles0000664000000000000000000000050415116102070012035 0ustar /etc/logrotate.d/sauce /etc/init.d/sauce /etc/sauce/blmessage-site.text /etc/sauce/blmessage-addr.text /etc/sauce/config /etc/sauce/db.manual /etc/sauce/sys-config /etc/sauce/set-firewall /etc/sauce/policy /etc/userv/services.d/sauce-userblacklist /etc/userv/services.d/sauce-firewall /etc/userv/services.d/sauce-rcptpolicy work/debian/control0000664000000000000000000000155015116102070011547 0ustar Source: sauce Section: mail Priority: extra Maintainer: Ian Jackson Rules-Requires-Root: binary-targets Standards-Version: 3.7.3.0 Build-Depends: tcl, debhelper-compat (= 13) Package: sauce Architecture: all Pre-Depends: ${misc:Pre-Depends} Depends: tcl, authbind, adns-tools, libtcl-chiark-1, ${misc:Depends} Recommends: exim4 | exim4-daemon-light | exim (>= 2.02-3) | exim-tls (>= 2.02-3), userv Description: SMTP defence software against spam SAUCE (Software Against Unsolicited Commercial Email) sits between the Internet and your existing Mail Transfer Agent (e.g. Exim). It does a number of checks on incoming mail, including being able to blacklist senders and their sites automatically when they mail special `spam bait' addresses. . This is a BETA version and is best used by mail experts only. work/debian/copyright0000664000000000000000000000310715116102070012077 0ustar This is Debian/GNU Linux's prepackaged version of Ian Jackson's `SAUCE' anti-spam software utility. This package was put together from the upstream sources by the upstream author. Please contact Ian Jackson at for matters relating to the Debian package in particular or for general enquiries about sauce. The changes were to add support for the Debian package maintenance scheme, by adding various debian/*. There is currently no automatic integration of this package with your existing mail transfer system; the sauce software is installed and configured pretty much ready to run, but you must arrange yourself for it to be invoked. SAUCE is Copyright (C)1997-2003 Ian Jackson . SAUCE is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License with your Debian GNU/Linux system, in /usr/share/common-licenses/GPL, or with the Debian GNU/Linux userv source package as the file COPYING; if not, email me at one of the addresses above or write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. work/debian/cron.weekly0000775000000000000000000000060615116102070012333 0ustar #!/bin/sh # $Id: cron.weekly,v 1.3 2004/09/05 15:21:22 ian Exp $ . /etc/sauce/sys-config test -x /usr/sbin/sauceadmin || exit 0 egrep '^\#.*sauce' /etc/inittab >/dev/null || exit 0 # Cycle logs cd /var/log/sauce savelog -c $SAUCE_LOGS_SAVE -m $SAUCE_LOGS_MODE \ -u $SAUCE_USER -g $SAUCE_GROUP \ startup.log debug.log notice.log dbreasons.log error.log fatal.log sauceadmin reopenlogs work/debian/logrotate0000664000000000000000000000077215116102070012074 0ustar /var/log/sauce/dbreasons.log /var/log/sauce/notice.log /var/log/sauce/error.log /var/log/sauce/reject.log /var/log/sauce/fatal.log { rotate 7 create 0644 mail mail weekly missingok compress lastaction if test -x /usr/sbin/sauceadmin; then sauceadmin reopenlogs fi endscript } /var/log/sauce/debug.log { rotate 7 create 0640 mail mail daily missingok compress lastaction if test -x /usr/sbin/sauceadmin; then sauceadmin reopenlogs fi endscript } work/debian/rules0000775000000000000000000000630515116102070011227 0ustar #!/usr/bin/make -f # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: rules,v 1.23.4.3 2008/03/08 16:29:36 ian Exp $ SHELL=/bin/bash package=sauce revision=$(shell dpkg-parsechangelog | sed -n 's/^Version:.*-//p') verext=-$(revision)deb DH_P=-P debian/tmp build-indep: $(checkdir) rm -f settings $(MAKE) prefix=/usr build: build-indep binary: binary-indep build-arch binary-arch: # we only produce Architecture: all packages clean: $(checkdir) -rm -f build -$(MAKE) -i distclean -rm -rf *~ debian/tmp debian/*~ debian/files* debian/substvars* dh_clean binary-indep: checkroot build-indep $(checkdir) -rm -rf debian/tmp install -d debian/tmp/DEBIAN debian/tmp/usr/{bin,sbin} install -d debian/tmp/{etc,usr/share,usr/share/doc}/sauce install -d debian/tmp/etc/{logrotate.d,init.d,userv/services.d} install -d debian/tmp/var/{log,lib}/$(package) install -d -m 750 debian/tmp/var/lib/$(package)/policies $(MAKE) install install_doc prefix=debian/tmp/usr \ doc_dir=debian/tmp/usr/share/doc/sauce etc_dir=debian/tmp/etc set -e; for f in `grep '^/etc/userv/services.d/' debian/conffiles`; do \ mv debian/tmp$$f:example debian/tmp$$f; \ done install -m 644 debian/logrotate debian/tmp/etc/logrotate.d/sauce install -m 755 debian/sauce-run debian/tmp/usr/sbin/sauce-run dh_installinit $(DH_P) dh_installsystemd $(DH_P) dh_installdeb $(DH_P) install -m 644 debian/conffiles debian/tmp/DEBIAN/. install -m 644 debian/copyright debian/tmp/usr/share/doc/$(package)/. install -m 644 debian/changelog debian/tmp/usr/share/doc/$(package)/changelog.Debian chmod 644 debian/tmp/usr/share/doc/$(package)/* gzip -9nv debian/tmp/usr/share/doc/$(package)/changelog.Debian install -m 644 db.manual blmessage-*.text debian/sys-config \ debian/tmp/etc/sauce/. install -m 755 debian/set-firewall debian/tmp/etc/sauce/. echo '# You may put SAUCE configuration here.' \ >debian/tmp/etc/sauce/config (echo '# You may put SAUCE policy here; load with sauce-setsyspolicy.'\ && echo .) >debian/tmp/etc/sauce/policy dpkg-gencontrol -isp chown -R root:root debian/tmp chown -R mail:root debian/tmp/var/{lib,log}/sauce debian/tmp/etc/sauce/* chown root:root debian/tmp/etc/sauce/sys-config chmod -R u+w,go-ws,a+rX debian/tmp dpkg --build debian/tmp .. define checkdir test -f sauce.tcl endef source diff: @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false checkroot: $(checkdir) test root = "`whoami`" .PHONY: binary binary-arch binary-indep clean checkroot work/debian/salsa-ci.yml0000664000000000000000000000013715116102070012363 0ustar --- include: - https://salsa.debian.org/salsa-ci-team/pipeline/raw/master/recipes/debian.yml work/debian/sauce-run0000775000000000000000000000213715116102070011776 0ustar #!/bin/sh # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: sauce-run,v 1.6 2003/06/15 15:46:40 ian Exp $ . /etc/sauce/sys-config cd /var/lib/sauce exec >>/var/log/sauce-startup.log 2>&1 exec su $SAUCE_USER -s /bin/sh -c ' set -e echo "`date`" sauce starting . /etc/sauce/sys-config set +e authbind sauce rc=$? echo "`date`" sauce terminated $rc ' work/debian/sauce.init0000775000000000000000000000227515116102070012141 0ustar #!/bin/sh # ### BEGIN INIT INFO # Provides: sauce # Required-Start: $remote_fs $syslog $named $time $network # Required-Stop: $remote_fs $syslog $named $time $network # Default-Start: 2 3 4 5 # Default-Stop: 0 1 6 # Short-Description: Start or stop SAUCE ### END INIT INFO test -x /usr/sbin/sauce-run || exit 0 . /lib/lsb/init-functions . /etc/sauce/sys-config set -e case "$1" in start) if sauceadmin '' 2>/dev/null >/dev/null; then exit 0; fi echo Starting smapblocking mail receiver: sauce. /usr/sbin/sauce-run & /usr/sbin/sauce-await-startup if sauceadmin ''; then exit 0; fi echo 'Startup failed.' >&2 exit 1 ;; stop) echo -n "Stopping spamblocking mail receiver: " set +e sauceadmin --sauceadmin-connrefused-ok=true shutdown set -e echo -n sauce start-stop-daemon --stop -oq --retry 30 -u $SAUCE_USER -n sauce echo "." ;; restart) $0 stop $0 start ;; reload) echo -n "Reloading sauce configuration..." sauceadmin --sauceadmin-connrefused-ok=true readconfig || test $? = 1 echo "done." ;; force-reload) $0 reload ;; *) echo "Usage: /etc/init.d/sauce {start|stop|reload|restart|force-reload}" >&2 exit 1 ;; esac exit 0 work/debian/sauce.postinst0000664000000000000000000000264015116102070013052 0ustar #!/bin/sh # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: postinst,v 1.10.2.1 2008/03/08 16:16:12 ian Exp $ set -e case "$1" in configure) case "$2" in 0.7.?|0.7.1[0-4]|0.7.99.0.*) printf "Clearing bug-induced cruft from site-annoy database..." /usr/share/sauce/clean-site-annoy echo ' done.' ;; *) find /var/lib/sauce -name 'db.site-annoy.*.csa~' \ -mtime +60 -ctime +60 -exec rm '{}' \; ;; esac sauce9-convert /var/lib/sauce x=`find /var/lib/sauce -maxdepth 1 -name 'db.*.*' -exec echo y \;` if [ "x$x" != x ]; then echo 'Arranging to clean up old db.* files ...' echo sauce9-convert /var/lib/sauce | at now +40 days fi ;; esac #DEBHELPER# work/debian/sauce.postrm0000664000000000000000000000171715116102070012517 0ustar #!/bin/sh # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: postrm,v 1.6 2004/01/14 22:59:13 ian Exp $ if [ "x$1" = xpurge ] then rm -rf /etc/sauce /var/lib/sauce /var/log/sauce /var/run/source fi #DEBHELPER# work/debian/sauce.service0000664000000000000000000000226315116102070012630 0ustar # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. [Unit] Description=spamblocking mail receiver [Service] Type=exec User=mail WorkingDirectory=/var/lib/sauce ExecStart =sh -c '. /etc/sauce/sys-config && exec authbind sauce' ExecStartPost=/usr/sbin/sauce-await-startup # Did SAUCE actually start? ExecStartPost=sauceadmin "" ExecStop=sauceadmin --sauceadmin-connrefused-ok=true shutdown TimeoutStopSec=30 [Install] WantedBy=multi-user.target work/debian/set-firewall0000775000000000000000000000005615116102070012470 0ustar #!/bin/sh exec userv root sauce-firewall "$@" work/debian/sys-config0000775000000000000000000000041115116102070012146 0ustar # You may edit this file to change the behaviour of # /etc/cron.weekly/sauce and other startup/maintenance scripts. exit 0 # Remove the preceding line when you've configured sauce umask 022 PATH=/usr/local/sbin:/sbin:/usr/sbin:$PATH export PATH SAUCE_USER=mail work/debian/tests/0000775000000000000000000000000015116102070011305 5ustar work/debian/tests/control0000664000000000000000000000016215116102070012707 0ustar Tests: t-startup Depends: @, ed, authbind Restrictions: allow-stderr, needs-root, isolation-machine, needs-reboot work/debian/tests/t-startup0000775000000000000000000000222615116102070013200 0ustar #!/bin/bash set -ex set -o pipefail exec >&2 save-logs () { if [ "x$AUTOPKGTEST_ARTIFACTS" = x ]; then return; fi a="$AUTOPKGTEST_ARTIFACTS" mkdir -p "$a"/{log,etc} cp -a /var/log/sauce* "$a/log/." cp -a /etc/. "$a/etc/." } trap ' exit_rc=$? set +e save-logs exit $exit_rc ' EXIT check-status () { # if sauceadmin works at all, it's running output=$(sauceadmin 'expr 2+3') test "x $output" = "x => 5" } resume- () { sed /etc/sauce/config ' s/^local_interface .*/local_interface 127.0.0.1/; ' dd if=/dev/urandom bs=1 count=8 | wc -c mkdir -p /etc/authbind/byport touch /etc/authbind/byport/25 chown root:mail /etc/authbind/byport/25 chmod 554 /etc/authbind/byport/25 ed < $answers {} OK # permanent failure (domain unknown) => {} $emsgstr NXDOMAIN # permanent failure (type unknown) => {} $emsgstr NOTYPE # permanent failure (misconfigured) => {} $emsgstr MISCONFIG # temporary failure =>X # $emsgstr is always a single line # global variables: # adns $adnsresid:$adnsresno # adnsresid the actual adns resolver handle # dns_refcount($adns) how many outstanding queries, +1 if current resolver # state variables: # adns $adns at query start # adnsid actual adns query handle # emsgprefix used for error message # pdesc used for debug0 trace load chiark_tcl_adns-1.so set rrdata_adnstype(MX) mx set rrdata_adnstype(A) a set rrdata_adnstype(addr) addr set rrdata_adnstype(TXT) txt set rrdata_adnstype(PTR) ptr- if {![info exists adnsresno]} { set adnsresno 0 } proc dns_deref {adns} { upvar #0 dns_refcount($adns) refcount if {[incr refcount -1] > 0} return debug0 1 "adns $adns all-done" adns destroy-resolver [lindex [split $adns :] 0] } proc dns_readconfig {} { global adns if {[info exists adns]} { dns_deref $adns unset adns } } proc dns__errcallback {msg} { log error $msg } thread_typedefine dns {domain type cnameok} { global adns adnsresid adnsresno adns_options var_dir rrdata_adnstype if {![info exists adns]} { set adnsresid [eval \ [list adns new-resolver -errcallback dns__errcallback] \ [split $adns_options]] incr adnsresno set adns [list $adnsresid:$adnsresno] upvar #0 dns_refcount($adns) refcount set refcount 1 debug0 1 "adns $adns started" } else { upvar #0 dns_refcount($adns) refcount } set domain [string tolower $domain] set adnsopts [list -resolver $adnsresid] set state(emsgprefix) "Error during DNS $type lookup for $domain" set state(adns) $adns if {$cnameok} { set cnokstr "~" } else { set cnokstr "!" lappend adnsopts -cname-forbid } set state(pdesc) "$state(desc) / $adns $domain $type$cnokstr" set state(adnsid) [eval \ [list adns asynch dns_yes dns_no dns_no $id \ $rrdata_adnstype($type) $domain] \ $adnsopts] incr refcount return $id } ERROR-ON-SHUTDOWN { catch { adns asynch-cancel $state(adnsid) } } proc dns_yes {id args} { eval thread_crosscall dns $id yes $args } proc dns_no {id args} { eval thread_crosscall dns $id no $args } thread_chainproc dns yes {etype ecode ename estring owner cname rrset} { unset state(adnsid) debug0 1 "$state(pdesc) => OK $rrset" dns_deref $state(adns) thread_finish dns $id $rrset {} OK } thread_chainproc dns no {etype ecode ename estring owner cname rrset} { unset state(adnsid) set emsgstr "$state(emsgprefix): $estring" debug0 1 "$state(pdesc) !> $ecode $ename $estring" dns_deref $state(adns) if {$ecode <= 99} { thread_error dns $id $emsgstr {} } elseif {$ecode <= 199} { thread_finish dns $id {} $emsgstr MISCONFIG } elseif {$ecode <= 299 || ![string compare $ename nxdomain]} { thread_finish dns $id {} $emsgstr NXDOMAIN } elseif {![string compare $ename nodata]} { thread_finish dns $id {} $emsgstr NOTYPE } else { error "Internal error: unexpected status: $ecode $ename" } } ########## dnsptr threads # # thread_start dnsptr $desc $ipaddr # # success => $ipaddr {} # permanent failure => {} $error # temporary failure =>X # $error is a single line string # state variables: # ipaddr address for which PTR is requested # dnsid id of DNS query subthread (unset => none) # remain list of unchecked returns from PTR in-addr lookup (unset until DNS finishes) # errs list of hard error message(s) thread_typedefine dnsptr {ipaddr} { set state(ipaddr) $ipaddr set ptr in-addr.arpa foreach octet [split $ipaddr .] { set ptr $octet.$ptr } set state(dnsid) [thread_start dns $state(desc) $ptr PTR 1] thread_join dnsptr $id dns $state(dnsid) dns_rvok dns_rverr } ERROR-ON-SHUTDOWN { catch { thread_cancel $state(dnsid) } } thread_chainproc dnsptr dns_rvok {answers emsgstr how} { unset state(dnsid) if {[llength $answers]} { set state(remain) $answers set state(errs) {} dnsptr_continue } else { thread_finish dnsptr $id {} $emsgstr } } thread_chainproc dnsptr dns_rverr {emsg} { unset state(dnsid) thread_error dnsptr $id $emsg {} } thread_subproc dnsptr continue {} { if {![llength $state(remain)]} { thread_finish dnsptr $id {} \ "$state(ipaddr) -> [join $state(errs) {; }]" return } set remain $state(remain) set try [lindex $remain 0] set state(remain) [lreplace $remain 0 0] set state(dnsid) [thread_start dns $state(desc) $try A 0] thread_join dnsptr $id dns $state(dnsid) dns_fwok dns_fwerr $try } thread_chainproc dnsptr dns_fwok {try answers emsgstr how} { unset state(dnsid) if {![string length $answers]} { lappend state(errs) "$try -> $emsgstr" } else { foreach ans $answers { if {"$ans"=="$state(ipaddr)"} { thread_finish dnsptr $id $try {} return } } lappend state(errs) "$try -> [join $answers {, }]" } dnsptr_continue } thread_chainproc dnsptr dns_fwerr {try emsg} { unset state(dnsid) thread_error dnsptr $id "$try -> $emsg" {} } work/example-config.text0000664000000000000000000000165115116102070012530 0ustar # Some places here I've changed domains to EXAMPLE.COM etc. to avoid # braindamage where people fail to edit config files. Also, I've # elided some stuff about what bait and bypass addresses there are on # my system. local_interface 172.30.206.1 local_domain chiark.EXAMPLE.COM local_domain davenant.EXAMPLE.COM # [excised] debug_level 1 addr_pattern admin mailadmin@ # [excised] addr_pattern bypass .+\+sauce-bypass\+.*@.* # [ excised statements of the form addr_pattern bait @ ] require_messageid false ipaddr_phase_proportion 256 ipaddr_phase_offset 89 addr_whitelist_timeout 2mth site_whitelist_timeout 2mth remember_addr_defer 2mth remember_site_defer 2mth annoy_partrespevery 70s annoy_actout_nopartresp 80s annoy_actout_max 170s rbl rbl.maps.vix.com reject rbl dul.maps.vix.com reject rbl relays.radparker.com reject rbl relays.orbs.org 25h 25h # $Id: example-config.text,v 1.1 1999/10/17 18:49:09 ian Exp $ work/firewall-example0000775000000000000000000000051415116102070012105 0ustar # Firewall setup fragment for Linux ipchains: # Deal with repeated SMTP connects which SAUCE wants to blackhole #ipchains=ipchains -v ipchains=ipchains #extraconds='-i eth0' extraconds='' #destaddrs=chiark.greenend.org.uk destaddrs=0.0.0.0/0 $ipchains -N Sauce $ipchains -A input -j Sauce $extraconds -p tcp -y -d $destaddrs smtp work/firewall.tcl0000664000000000000000000000450615116102070011237 0ustar #!/usr/bin/tclsh # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: firewall.tcl,v 1.6 2003/09/20 18:22:59 ian Exp $ # usage: .../firewall -- [ ...] # invoked by SAUCE from userv using with-lock set ipchains ipchains set iptables iptables set chain [lindex $argv 0] set target [lindex $argv 1] if {"[lindex $argv 2]" != "--"} { error "bad delimiter" } set addrs [lrange $argv 3 end] if {[file exists /proc/net/ip_tables_names]} { set ipspongs $iptables if {![string compare $target DENY]} { set target DROP } } else { set ipspongs $ipchains if {![string compare $target DROP]} { set target DENY } } set lchan [open |[list $ipspongs -n -L $chain] r] set ix 0 while {[gets $lchan l] >= 0} { if {[regexp {^Chain \w+ \(.*\)\:?$} $l] || \ [regexp {^target\s+prot\s+opt\s+source\s+destination} $l]} { } elseif {[regexp \ {^\w+\s+\w+\s+\-+\s+([.0-9]+)\s+0\.0\.0\.0/0(?:\s+n/a)?\s*$}\ $l dummy b_now_this]} { set b_now($b_now_this) [incr ix] } else { error "unknown $l" } } close $lchan foreach a $addrs { if {![regexp {^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$} $a ma]} { error "bad address $a" } set b_want($ma) 1 } proc modify_chain {what addr} { global ipspongs chain target set cmd [list $ipspongs $what $chain -j $target -s $addr] puts $cmd lappend cmd >@ stderr 2>@ stderr eval exec $cmd } foreach x [array names b_now] { if {[info exists b_want($x)]} continue modify_chain -D $x } foreach x [array names b_want] { if {[info exists b_now($x)]} continue modify_chain -A $x } work/instlib.tcl0000664000000000000000000000214315116102070011071 0ustar ########### instlib.tcl # Library procedures used by install programs # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: instlib.tcl,v 1.5 2003/06/15 15:46:40 ian Exp $ proc string_quote {v allow0} { regsub -all {[[]\"\$\\]} $v {\\\1} v if {[regexp {[^-._,:/0-9A-Za-z]} $v] || !$allow0 && ![string length $v]} { set v "\"$v\"" } return $v } work/junk0000664000000000000000000000027615116102070007620 0ustar if {[info exists state(no)]} { if {$state(admin)} { ic_msg_accept $eom } else { set state(whyreject) $state(no) ic_msgnoa_reject $eom "550 $blacklist_message" } } else work/library.tcl0000664000000000000000000001541215116102070011074 0ustar ########### library.tcl # Utility routines, eg, for munging addresses (RFC821) etc. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: library.tcl,v 1.23 2003/06/15 15:46:40 ian Exp $ load chiark_tcl_hbytes-1.so load chiark_tcl_crypto-1.so set lg_outs {fatal error reject dbreasons notice debug} set lg_sev_outs(debug) { debug} set lg_sev_outs(notice) { notice debug} set lg_sev_outs(dbreasons) { dbreasons notice debug} set lg_sev_outs(reject) { reject notice debug} set lg_sev_outs(error) { error reject notice debug} set lg_sev_outs(fatal) {fatal error reject notice debug} foreach ll $lg_outs { set lg_chan($ll) stderr } proc reopenlogs {} { global lg_outs log_dir log_mode log_mode_debug lg_chan log_stderr if {$log_stderr} { return } set ofiles {} set mode $log_mode_debug foreach ll $lg_outs { catch { unset of } if {[info exists lg_chan($ll)]} { set of $lg_chan($ll) } set f [open $log_dir/$ll.log {APPEND WRONLY CREAT} $mode] if {[catch { fconfigure $f -buffering line } emsg]} { catch { close $f } error $emsg } catch { if {"$of" == "stderr"} { flush $of } else { close $of } } set lg_chan($ll) $f set mode $log_mode } log notice "logfiles (re)opened" } proc debugn {rep lev argl} { global debug_level if {$debug_level >= $lev} { log debug "[string repeat { } $rep][eval concat $argl]" } } proc debug {lev args} { debugn [expr {[info level]-1}] $lev $args } proc debug0 {lev args} { debugn 0 $lev $args } proc log {severity msg} { global lg_sev_outs current_bigerr lg_chan log_stderr if {[catch { set datestr [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}] } emsg]} { set datestr "($emsg)" } set llhs {} regsub -all -nocase {\\} $msg {\\\\} msg regsub -all -nocase {\n} $msg "\\n" msg while {[regexp -nocase {^([ -~\t]*)([^ -~\t])(.*)$} $msg all lhs here msg]} { binary scan $here H* here append llhs $lhs "\\x$here" } append llhs $msg set lfile {} foreach ll $lg_sev_outs($severity) { if {[info exists lg_chan($ll)] && "$lfile" == "$lg_chan($ll)"} { continue } if {[catch { puts $lg_chan($ll) "$datestr: $severity: $llhs" set lfile $lg_chan($ll) } emsg]} { set current_bigerr "$ll log error: $emsg" catch { puts $lg_chan(fatal) "$datestr: fatal: error logging for $ll: $emsg" } } } } proc logreject_val {varname key val} { upvar $varname var if {![string length $val]} return append var " $key=" if {[regexp -nocase {[^-+.0-9a-z@%_$*:<>]} $val]} { regsub -all {"} $val {&&} val append var "\"$val\"" } else { append var $val } } proc logreject {severity statevar when saidwhat args} { global annoy_grumpy annoy_actout_max upvar $statevar state set m $when if {[info exists state(rh)]} { logreject_val m host $state(rh) } else { logreject_val m addr $state(ra) } if {[info exists state(mf_lp)]} { set sender $state(mf_lp)@$state(mf_dm) if {"$sender" == "@"} { set sender {<>} } logreject_val m from $sender } logreject_val m cmd $state(smtpcmd) logreject_val m readerr $state(smtpreaderr) logreject_val m resp $saidwhat foreach cm {conn msg} { foreach rd {rej defer} { foreach reas $state(${rd}_${cm}) { logreject_val m ${rd}-${cm} $reas } } } if {[llength $state(resentmids)]} { foreach i $state(resentmids) { logreject_val m resent-id $i } } elseif {[info exists state(mid)]} { logreject_val m id $state(mid) } foreach x $state(att_rcpts) { manyset $x t r c if {"$t" == "$c"} { set tc $t } else { set tc $t-$c } logreject_val m rcpt-$tc $r } foreach x $state(rbl_hits) { logreject_val m rbl $x } foreach {key val} $args { logreject_val m $key $val } log $severity $m } proc manyset {list args} { foreach val $list var $args { upvar 1 $var my set my $val } } ########## general utility functions proc smtp_prefix_response {message_in code message_out_var} { upvar 1 $message_out_var message_out regsub -all {(?m)^} $message_in "$code-" message regsub "$code-(\[^\\n\]*)\$" $message "$code \\1" message_out } proc domain_ok {domain} { return [expr { ![regexp -nocase {[^-0-9a-z.]} $domain] && [regexp -nocase {^[-0-9a-z]+(\.[-0-9a-z]+)*$} $domain] && [string length $domain] <= 255 }] } proc lp_quote {lp} { regsub -all {([^-.!#$%&'*+/0-9=?A-Z^_`a-z{|}~])} $lp {\\\1} lp return $lp } proc proto_quote {msg} { regsub -all {\n} $msg " // " msg regsub -all {[^\t\040-\176]} $msg ? msg return $msg } proc date_822 {} { clock format [clock seconds] -gmt true -format {%d %b %Y %T +0000 (GMT)} } proc urandom_hex {bytes} { # returns *hex* set r [hbytes random $bytes] if {[string length $r] != $bytes * 2} { error "hbytes random failed `$r'" } return $r } proc singleline {manylines_onestring} { return [join [split $manylines_onestring "\n"] "; "] } proc ia2value {dottedquad minbitlen} { set l [split $dottedquad .] if {[llength $l] > 4} { error "too many bytes in IP address/mask" } if {![llength $l]} { error "empty IP address/mask" } if {[llength $l]*8 < $minbitlen} { error "IP address/mask too short (need $minbitlen bits)" } set ac 0 set sh 24 foreach v $l { if {$v > 255} { error "IP address byte out of range" } incr ac [expr {$v << $sh}] incr sh -8 } return $ac } proc address_dequote {lpvar domvar} { upvar 1 $lpvar lp upvar 1 $domvar dm if {![domain_ok $dm]} { error "invalid domain" } while {[regexp {^@([^:,]+)[:,](.+)$} $lp all adm rhs]} { if {![domain_ok $adm]} { error "invalid source route syntax" } set lp $rhs } if {![regexp {^\"((?:[^\"\\]|\\.)+)\"$} $lp all lp] && ![regexp {^([-!#$%&'*+/0-9=?A-Z^_`a-z{|}~]|\\.)+(\.([-!#$%&'*+/0-9=?A-Z^_`a-z{|}~]|\\.)+)*$} $lp]} { error "invalid local-part syntax" } regsub -all {\\(.)} $lp {\1} lp } work/msgdata.tcl0000664000000000000000000005545615116102070011064 0ustar ########### msgdata.tcl # Routines (part of main program) for dealing with DATA. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: msgdata.tcl,v 1.50.2.2 2008/03/08 17:29:37 ian Exp $ # While receiving the message data, we are either: # * Receiving the header: # No DATA has been issued to the local MTA; the header info is # accumulating in our VM. We may have address verification # threads outstanding. In this state rej_*/defer_* variables # indicate whether we will want to accept or reject the message # when we've seen all the headers. In this state # state(hdrscomplete) is unset. Functions called in this state # have names starting hdr_... # * Awaiting address verifications: # We've received and parsed the header, but we're waiting for # outstanding addresses from the header to finish verifying. In # this state we're always calling msg_maincontrol. In this state # state(hdrscomplete) is 1. # * Receiving data, thinking we will accept the message: # DATA has been issued to the local MTA and the header and perhaps # some of the body have been sent to it. Functions called in this # state have names starting body_... # * Receiving the body, but we will reject or discard the message: # The local MTA has not been sent DATA. We just throw away the # data, and we pass about the SMTP status reply to give to the # caller. Functions called in this state have names starting # bodyrej_... # Functions callable in any of these states have names starting msg_... # Header parsing ... # a_kinds Can't Do what Pass Response # parse? with addrs? to MTA? to final dot # lax Ignore Ignore Pass 250? # unchecked Ignore Ignore Pass 250? # unchecked + lax Ignore Ignore Pass 250? # normal 550 Check Pass 250? # normal + lax 550 Check Pass 250? # bait Ignore Blacklist Discard 250 # bait + lax Ignore Blacklist Pass 250? # unchecked + bait Ignore Blacklist Pass 250? # unchecked + bait + lax Ignore Blacklist Pass 250? # normal + bait Ignore Blacklist Discard 550 # normal + bait + lax Ignore Blacklist Discard 550 thread_subproc ic a_kind {kind} { return [expr {[lsearch -exact $state(a_kinds) $kind] >= 0}] } thread_subproc ic rej_bl {what inwhere} { ic_rej "Blacklisted $inwhere `[proto_quote $what]'" } thread_subproc ic rej {what} { if {[lsearch -exact $state(rej_msg) $what] == -1} { lappend state(rej_msg) $what } } thread_chainproc ic askfordata_done {} { set state(header) {} set state(currenthn) {} set state(currenthl) {} set state(resentmids) {} set orig {} if {[string length $state(mf_dm)]} { lappend orig $state(mf_lp)@$state(mf_dm) } set state(originators) $orig set state(originators_tochk) {} chanset_hide $state(chan) 3 1 foreach k $state(a_kinds) { set ka($k) 1 } set state(a_kinds) [lsort [array names ka]] threadio_gets ic $id $state(chan) hdr_read {} } thread_chainproc ic hdr_read {data} { # This is the main event callback for reading header lines. global max_header_size blacklist_message require_messageid regexp {^.*} $data data ic_msg_checkeof if {"$data" == "."} { set eom 1 } else { set eom 0 } debug 3 "hdr_read >$data<" if {[regexp {^[ \t]} $data]} { if {![string length $state(currenthn)]} { ic_hdr_bad 0 \ "first line of header was header field continuation" return } append state(currenthl) "\n$data" if {[string length $state(currenthl)] > $max_header_size} { ic_hdr_bad 0 \ "continued header $state(currenthn) too large (>$max_header_size bytes)" return } } elseif {[regexp {^([\041-\071\073-\176\241-\376]+)[ \t]*:} \ $data all newhn]} { ic_hdr_process1 $eom $state(currenthn) $state(currenthl) set state(currenthn) $newhn set state(currenthl) $data } elseif {$eom || ![string length $data]} { # End of headers ic_hdr_process1 $eom $state(currenthn) $state(currenthl) set state(currenthn) {} set state(currenthl) {} if {!$eom} { append state(header) "$data\n" } if {![llength $state(originators)]} { ic_rej "No originators in envelope or body" } elseif {$require_messageid && ![info exists state(mid)]} { ic_rej "No Message-ID header" } elseif {$require_messageid && $state(resentany) && ![llength $state(resentmids)]} { ic_rej "Resent- header(s), but no Resent-Message-ID" } ic_hdr_endhdrs $eom return } else { ic_hdr_bad 0 "Header data malformed" return } threadio_gets ic $id $state(chan) hdr_read {} } thread_subproc ic hdr_bad {eom problem} { ic_rej $problem ic_hdr_endhdrs $eom } thread_subproc ic msg_checkeof {} { global canonical_hostname if {[eof $state(chan)]} { catch_close_cleardesc state(mtachan) ic_commandfinalresponse major \ "421 $canonical_hostname Connection dropped in message data" return -code return } } thread_chainproc ic msg_timedout {} { global canonical_hostname catch_close_cleardesc state(mtachan) fileevent $state(chan) readable {} ic_commandfinalresponse major \ "421 $canonical_hostname Timed out waiting for message data" ic_msg_resetvars } thread_subproc ic hdr_process1 {eom hn hl} { global blacklist_message max_header_size errorInfo header_reject_res global errorCode errorInfo debug 3 "hdr_process1 >$eom|$hn|$hl<" if {![string length $hn]} return set lowerhn [string tolower $hn] regsub {^[^:]+:[ \t]*} $hl {} hv if {[regexp {^(?:resent\-)?to$} $lowerhn] && [regexp {^\<[-_0-9A-Za-z]*:;\>$} $hv]} { set hv "\"$hv\":;" set hl "$hn: $hv" ic_rej "syntax error in $hn header, SAUCE will encapsulate in \"...\" if it accepts" } append state(header) "$hl\n" if {[string length $state(header)] > $max_header_size} { ic_rej "header $hn too large (>$max_header_size bytes)" return } regsub {^[^:]+:[ \t]*} $hl {} hl # fixme: confusion about value in hl # Much of the rest of this function seems to date from # before we stripped the header name from the front of hl. # hl is now te same as hv; we should stop modifying hl and # instead change code below to use hv where appropriate (nearly # always) and hl otherwise. if {[regexp -nocase \ {^resent-(from|reply-to|sender|message-id|to|cc|bcc|date)$} \ $hn]} { set state(resentany) 1 } if {[regexp -nocase {^message-id$} $hn]} { regsub -nocase {^message-id:[ \t\n]*} $hl {} thismid if {[info exists state(mid)]} { ic_rej "Message-ID header appears twice" append state(mid) "/$thismid" } else { set state(mid) $thismid } } elseif {[regexp -nocase {^resent-message-id$} $hn]} { regsub -nocase "^resent-message-id:\[ \t\n\]*" $hl {} thismid lappend state(resentmids) $thismid } if {[regexp -nocase {^(resent-)?(from|sender|reply-to)$} $hn]} { if {[catch { ic_hdr_recipients $eom $hn $hl } emsg]} { if {"$errorCode" == "SAUCE BADHDR"} { debug 3 "header error >$emsg|$errorInfo<" ic_rej "error in $hn header: [singleline $emsg]" } else { error $emsg "$errorInfo\nin $hn header" $errorCode } } } if {[info exists header_reject_res($lowerhn)]} { foreach re $header_reject_res($lowerhn) { if {[info exists state(add_bl)]} break if {[catch { if {[regexp -- $re $hl]} { ic_rej "policy error in $hn header" } } emsg]} { log error "header rejection regexp problem ($re): $emsg" } } } } thread_subproc ic hdr_err {emsg} { error $emsg {} {SAUCE BADHDR} } thread_subproc ic hdr_recipients {eom hn tf} { set lowerhn [string tolower $hn] debug 3 "hdr_recipients >$eom|$hn|$tf<" set colev 0 set uq {} while {[string length $tf]} { debug 3 "hdr_recipients >$lowerhn|$tf|$uq<" if {[regexp {^[ \n\t]+(.*)$} $tf all tf]} { } elseif {[regexp {^\((.*)$} $tf all tf]} { incr colev } elseif {$colev} { if {[regexp {^\)(.*)$} $tf all tf]} { incr colev -1 } elseif {[regexp {^[^\\\n()]+(.*)$} $tf all tf]} { } elseif {[regexp {^\\.(.*)$} $tf all tf]} { } elseif {[regexp {^\n(.*)$} $tf all tf]} { } else { ic_hdr_err "invalid text in comment" } } elseif {[regexp \ {^([\055\041\043-\047\051-\053\057-\071\075\077\101-\132\136-\176\200-\376]+)(.*)} \ $tf all xt tf]} { binary scan $xt H* xt append uq $xt } elseif {[regexp {^([][()<>@,;:\.])(.*)} $tf all xt tf]} { append uq $xt } elseif {[regexp {^"(.*)$} $tf all tf]} { while {[regexp {^([^"\\\n]+)(.*)$} $tf all qt tf] || \ [regexp {^\\(.)(.*)$} $tf all qt tf] || \ [regexp {^\\(\n)(.*)$} $tf all qt tf]} { binary scan $qt H* qt append uq $qt } if {![regexp {^\"(.*)$} $tf all tf]} { ic_hdr_err "missing end of quoted string" } } else { ic_hdr_err "lexical error" } } append uq , while {[string length $uq]} { debug 3 "hdr_recipients >$uq<" if {[regsub {^[0-9a-f.]+:([][0-9a-f.@,<>]*);} $uq {\1,} uq]} { } elseif {[regexp {^[0-9a-f.]*<([][0-9a-f.@]+)>,(.*)} \ $uq all ras uq]} { regsub {^(@[][0-9a-f.]:)*} $ras {} ras ic_hdr_1recipient $eom $hn $ras } elseif {[regexp {^([][0-9a-f.@]+),(.*)} $uq all ras uq]} { ic_hdr_1recipient $eom $hn $ras } elseif {[regexp {^,(.*)} $uq all uq]} { } else { ic_hdr_err "syntax error" } } } thread_subproc ic hdr_1recipient {eom hn ras} { debug 3 "hdr_1recipient >$eom|$hn|$ras<" if {![regexp {^([0-9a-f.]+)@([][0-9a-f.]+)$} $ras all lp dm]} { ic_hdr_err "invalid address" } foreach from {. [ ]} { foreach var {lp dm} { binary scan $from H* to regsub -all \\$from [set $var] $to $var } } set lp [binary format H* $lp] set dm [binary format H* $dm] set addr $lp@$dm lappend state(originators) $addr if {[ic_a_kind normal] && ![ic_a_kind bait]} { lappend state(originators_tochk) [list $lp $dm $state(currenthn)] } if {"[ds_get addr-list $addr]" == "black"} { ic_rej_bl $addr $hn } ic_msg_maincontrol $eom } thread_subproc ic hdr_endhdrs {eom} { # Called when we want to stop header parsing and go on to either # accept the data into our MTA, or junk it. # eom==1 means we've had final dot already. set state(hdrscomplete) 1 ic_msg_maincontrol $eom } thread_subproc ic msg_maincontrol {eom} { global blacklist_message # This function is called during header processing, when it # handles avf replies wrt one originator and simply queues the # next, if none have already been queued. It is also called at # the end of header parsing, to check if more verifies need to be # waited for, and in that case (ie, if state(hdrscomplete) is # set), is responsible for passing the main flow of control. debug 3 "originators_tochk >$state(originators_tochk)<" while 1 { if {[llength $state(rej_msg)]} { if {[info exists state(avfid)]} { thread_cancel avf $state(avfid) unset state(avfid) } set state(originators_tochk) {} } if {[info exists state(avfid)]} return if {![llength $state(originators_tochk)]} break manyset [lindex $state(originators_tochk) 0] lp dm hn set addr $lp@$dm set state(originators_tochk) [lreplace $state(originators_tochk) 0 0] if {![llength $state(rej_msg)]} { switch -exact -- [ds_get addr-list $addr] { white - whitesoon { } black { ic_rej_bl $addr $hn } default { set state(avfid) [thread_start avf \ "$state(desc) / verify $hn $lp@$dm" $lp $dm] thread_join ic $id avf $state(avfid) msg_origverify_ok \ msg_origverify_err $eom $lp@$dm $hn return } } } } debug 3 "originators >$state(originators)<" # No originators left to check and no such check in progress if {![info exists state(hdrscomplete)]} return debug 2 "originators verified, all complete $state(originators)" # OK, we have whole headers. There is no pending timeout or verification # thread, and are no unchecked originators. We can accept or reject it ! ic_msg_maybeblacklist set rej_this [concat $state(rej_conn) $state(rej_msg)] smtp_prefix_response [join $rej_this "\n"] 550 rej_response switch -exact $state(a_kinds) { {lax} - {unchecked} - {lax unchecked} - {bait lax} - {bait unchecked} - {bait lax unchecked} { ic_body $eom $rej_this } {normal} - {bait normal} - {lax normal} - {bait lax normal} { if {[llength $rej_this]} { ic_bodyrej $eom $rej_response } else { # Due to ic_msg_maybeblacklist we can be sure no bait if here ic_body $eom {} } } {bait} { ic_bodyrej $eom "250 [ic_transactionid]b" } default { error "internal error - kinds $state(a_kinds)" } } } thread_chainproc ic msg_origverify_ok {eom addr hn ok message} { unset state(avfid) if {!$ok} { ic_rej "$hn address `[proto_quote $addr]': [singleline $message]" } ic_msg_maincontrol $eom } thread_chainproc ic msg_origverify_err {eom addr hn message} { unset state(avfid) ic_msg_maincontrol $eom } # Accepting the message body ... thread_subproc ic body {eom rejwarnings} { threadio_commandresponse ic $id $state(mtachan) data {} \ body_data_ok {} $eom $rejwarnings } thread_chainproc ic body_data_ok {eom rejwarnings data} { global add_received add_warnings canonical_hostname if {![regexp {^3[0-9][0-9]} $data]} { ic_bodyrej $eom $data return } chanset_hide $state(mtachan) 1 3 set hdrdata {} if {$add_warnings} { foreach w $rejwarnings { append hdrdata "X-SAUCE-Warning: ($canonical_hostname) $w\n" } manyset [ic_getsiteannoy 0] annoyval annoystr if {$annoyval > 0} { append hdrdata \ "X-SAUCE-Notice: ($canonical_hostname) $annoystr" \ " ${annoyval}ms (delays likely)\n" \ " with $state(rh) \[$state(ra)\]\n" } } if {$add_received} { regsub {^.Name\: } {$Name: debian_version_0_9_0 $} {} rcsinfo if {![regexp {^[ $]*$} $rcsinfo]} { regsub {^debian_version_} $rcsinfo v rcsinfo regsub -all _ $rcsinfo . rcsinfo } else { regsub {^.Revision\: } {$Revision: 1.50.2.2 $} r rcsinfo } regsub {[ $]*$} $rcsinfo {} rcsinfo set date [date_822] if {[string length $state(ident)]} { set ident " ident $state(ident)" } else { set ident "" } append hdrdata \ "Received: from $state(rh) (\[$state(ra)\])$ident by $state(lh) (SAUCE $rcsinfo) with $state(smtpstyle) id [ic_transactionid]; $date\n" } append hdrdata $state(header) threadio_puts ic $id $state(mtachan) $hdrdata body_copy {} $eom } thread_chainproc ic body_copy {eom} { if {!$eom} { threadio_gets ic $id $state(chan) body_read {} } else { ic_body_eom } } thread_chainproc ic body_read {data} { global canonical_hostname taboo_virus_hack ic_msg_checkeof if {![string compare . $data]} { ic_body_eom } elseif {$taboo_virus_hack && [string match \ *TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA*\ $data]} { ic_bodybodyrej "554 virus flood (or bare executable) rejected" } else { threadio_puts ic $id $state(mtachan) "$data\n" body_copy {} 0 } } thread_subproc ic bodybodyrej {resp} { # Used for rejecting the message body after the header # has been read (ie, when we're already feeding the MTA data). catch_close_cleardesc state(mtachan) ic_bodyrej_startread [list ic_bodybodyrej_done $resp] } thread_subproc ic bodybodyrej_done {resp} { global annoyance_major chanset_hide $state(chan) 1 1 set annoychange $annoyance_major set irritvalx {} if {[info exists state(rcpts_errok_only)] && \ $state(rcpts_errok_only)} { set annoychange 0 set irritvalx - } manyset [ic_getsiteannoy $annoychange] irritval irritamt set irritamtl [string tolower $irritamt] logreject reject state command $resp $irritamtl "$irritval$irritvalx" threadio_puts ic $id $state(chan) "$resp\n" bodybodyrej_rejdone {} } thread_chainproc ic bodybodyrej_rejdone {} { ic_msg_resetvars ic_mtachan_open } thread_subproc ic body_eom {} { chanset_hide $state(mtachan) 1 1 threadio_commandresponse ic $id $state(mtachan) "." {} body_finish_ok {} } thread_chainproc ic body_finish_ok {data} { global addr_whitelist_delay addr_whitelist_timeout addr_verified_timeout global site_whitelist_delay site_whitelist_timeout site_verified_timeout if {![regexp -- {^250[- ](.*)} $data dm realdata]} { ic_commandresponse major $data } else { set mid [ic_body_mid] set minfo [ic_body_minfo $mid] # We don't make whitelist entries as a result of messages we # wanted to reject. Instead we verify them every time. Sorry # folks ! set wouldreject 0 foreach rd {rej defer} { foreach cm {conn msg} { if {[llength $state(${rd}_${cm})]} { set wouldreject 1 } } } if {!$wouldreject} { foreach as {addr site} \ itlist [list $state(originators) [list $state(ra)]] { foreach it $itlist { set st [ds_get $as-list $it] switch -exact -- $st { unknown - verified { set sl [list \ whitesoon [set ${as}_whitelist_delay] \ white [set ${as}_whitelist_timeout]] } white { set sl [list white [set ${as}_whitelist_timeout]] } default { set sl {} } } if {![llength $sl]} continue if {[catch { if {"[lindex $sl 0]" != "$st"} { eval [list setstate $as $it "$mid $data"] $sl } else { eval [list ds_set $as-list $it] $sl } } emsg]} { log error \ "cannot create whitelist entry for $as $it: $emsg" } } } } ic_commandresponse delivery \ "250 [ic_transactionid] [singleline $realdata]" manyset [ic_getsiteannoy 0] cannoy cannoydesc log notice \ "accepted $minfo via $state(rh) [string tolower $cannoydesc]=${cannoy}ms $data" } ic_msg_resetvars } thread_subproc ic transactionid {} { return sauce-$id-[expr {[clock seconds]/1000}]-$state(rcptcounter) } thread_subproc ic body_mid {} { if {[llength $state(resentmids)]} { return [lindex $state(resentmids) 0] } elseif {[info exists state(mid)]} { return $state(mid) } else { return "(No Message-ID)" } } thread_subproc ic body_minfo {mid} { set sender "$state(mf_lp)@$state(mf_dm)" if {"$sender" == "@"} { set sender {<>} } return "$mid from $sender" } # Alternatively, discard the body and RSET the sub-MTA thread_subproc ic bodyrej {eom why} { ic_msg_resethdrvars if {!$eom} { ic_bodyrej_startread [list ic_bodyrej 1 $why] } else { threadio_commandresponse ic $id $state(mtachan) rset {^2..} \ bodyrej_resetmta_ok {} $why } } thread_subproc ic bodyrej_startread {then} { threadio_gets ic $id $state(chan) bodyrej_read {} $then } thread_chainproc ic bodyrej_read {then data} { ic_msg_checkeof if {"$data" == "."} { eval $then } else { threadio_gets ic $id $state(chan) bodyrej_read {} $then } } thread_chainproc ic bodyrej_resetmta_greeting_ok {what data} { threadio_commandresponse ic $id $state(mtachan) \ "$state(helocmd) $state(helostring)" {^2..} \ bodyrej_resetmta_ok {} $what } thread_chainproc ic bodyrej_resetmta_ok {what data} { ic_commandresponse major $what ic_msg_resetvars } # Check if we want to blacklist thread_subproc ic blacklist_thing {sa value tellwho valdesc} { upvar #0 ${sa}_blacklist_timeout bl_to set st [ds_get $sa-list $value] set cd [ic_transactionid] set add_bl [join $state(add_bl) "; "] switch -exact -- $st { unknown - whitesoon - verified { log notice "$cd ... $sa $value ... blacklisting" set thread [thread_start notifybl \ "$state(desc) / notify-bl $sa $value" \ $tellwho $sa $valdesc $state(add_bl)] thread_join {} {} notifybl $thread addbl_done addbl_err \ $state(desc) $tellwho "$sa $value" setstate $sa $value $add_bl black $bl_to return 1 } black { log notice "$cd ... $sa $value ... refreshing blacklist" setstate $sa $value $add_bl black $bl_to return 1 } white { log notice "$cd ... $sa $value ... is whitelisted" return 0 } default { log error "$cd ... $sa $value ... unknown state $st" return 0 } } } thread_subproc ic blacklist_site {} { ic_blacklist_thing site $state(ra) \ "postmaster@$state(cmdomain)" \ "Calling IP address `$state(ra)'" } thread_subproc ic msg_maybeblacklist {} { global blacklist_all_addresses always_blacklist_site global chan_desc blacknone_message if {![info exists state(add_bl)]} return if {![llength $state(rej_msg)] && ![llength $state(rej_conn)]} { ic_rej $blacknone_message # If we had some other reason to reject it, use that. } set anyadded 0 set cd [ic_transactionid] log notice "$cd blacklisting because [join $state(add_bl) {; }]" foreach try $state(originators) { if {[ic_blacklist_thing addr $try $try \ "Originator address `$try'"]} { set anyadded 1 if {!$blacklist_all_addresses} break } } if {!$anyadded} { log notice "$cd ... unable to blacklist by originator ..." } if {!$anyadded || $always_blacklist_site} { if {[ic_blacklist_site]} { set anyadded 1 } } if {!$anyadded} { log notice "$cd ... unable to blacklist !" debug 1 "ra $state(ra) originators $state(originators) $state(header)" } } proc addbl_done {desc what where okcode} { log notice "$desc: blacklist notification sent to $where: $what: $okcode" } proc addbl_err {desc what where msg} { log notice "$desc: blacklist notification to $where failed: $what: $msg" } # General cleanup functions ... thread_subproc ic msg_resetvars {} { catch { thread_cancel avf $state(avfid) } ic_msg_resethdrvars foreach x { mf_lp mf_dm mf_parms hdrscomplete rcpts_errok_only add_bl mid resentany originators originators_tochk } { catch { unset state($x) } } foreach x {rej_msg defer_msg delay_msg att_rcpts a_kinds resentmids} { set state($x) {} } foreach x {resentany} { set state($x) 0 } } thread_subproc ic msg_resethdrvars {} { foreach x {header currenthn currenthl} { catch { unset state($x) } } } work/notifybl.tcl0000664000000000000000000001033615116102070011256 0ustar ########### msgdata.tcl # Code for notifying people that they have been blacklisted. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: notifybl.tcl,v 1.15 2006/04/02 18:27:23 ian Exp $ ########## notifybl threads # # thread_start notifybl $desc $addr_to_notify $site_or_addr # $desc_what_blacklisted $why # # state variables: # # sa $site_or_addr (ie, `site' or `addr') # lp local part to receive notice # dm domain to receive notice # toid global timeout # chan local MTA channel # whatbl what is being blacklisted # why and why # okcode the response code from the local MTA # blmessage the blacklist message we're going to send thread_typedefine notifybl {notifyaddr sa whatbl why} { global notifybl_timeout blmessage_addr blmessage_site global blmessage_sendmail_args set state(blmessage) [set blmessage_$sa] if {![string length $state(blmessage)]} { thread_error notifybl $id "blmessage $sa disabled" {} return } debug 1 [list notifybl $notifyaddr $whatbl $why] if {![regexp -nocase {^(.+)\@([.0-9a-z\-\[\]]+)$} \ $notifyaddr all lp state(dm)]} { error "trying to notify address $notifyaddr" } set state(sa) $sa set state(lp) [lp_quote $lp] set state(chan) [open |[concat \ [list sendmail] \ [split $blmessage_sendmail_args] \ [list -bs -oem] \ ] r+] set state(whatbl) $whatbl set state(why) $why fconfigure $state(chan) -blocking false -translation {binary crlf} chanset_desc $state(chan) "$state(desc) / local" set state(toid) [thread_after notifybl $id $notifybl_timeout timedout] threadio_commandresponse notifybl $id $state(chan) {} {^220} greeting_ok {} } { # ignore shutdown requests } { catch { after cancel $state(toid) } catch { close $state(chan) } } thread_chainproc notifybl greeting_ok {data} { global canonical_hostname threadio_commandresponse notifybl $id $state(chan) "HELO $canonical_hostname" \ {^2[0-9][0-9]} helo_ok {} } thread_chainproc notifybl helo_ok {data} { global canonical_hostname notifybl_bounces set bffrom $notifybl_bounces if {[string length $bffrom]} { append bffrom @ $canonical_hostname } threadio_commandresponse notifybl $id $state(chan) \ "MAIL FROM:<$bffrom>" {^2[0-9][0-9]} mailfrom_ok {} } thread_chainproc notifybl mailfrom_ok {data} { threadio_commandresponse notifybl $id $state(chan) \ "RCPT TO:<$state(lp)@$state(dm)>" \ {^2[0-9][0-9]} rcptto_ok {} } thread_chainproc notifybl rcptto_ok {data} { threadio_commandresponse notifybl $id $state(chan) DATA {^354} data_ok {} } thread_chainproc notifybl data_ok {data} { global canonical_hostname notifybl_localpart chanset_hide $state(chan) 1 3 threadio_puts notifybl $id $state(chan) \ "From: $notifybl_localpart@$canonical_hostname To: Recipient.suppressed:; Subject: $state(whatbl) has been blacklisted $state(blmessage) . " \ message_ok {} } thread_chainproc notifybl message_ok {} { chanset_hide $state(chan) 1 1 threadio_commandresponse notifybl $id $state(chan) {} {^250} finaldot_ok {} } thread_chainproc notifybl finaldot_ok {data} { regsub {^250[ \t]*} $data {} state(okcode) threadio_commandresponse notifybl $id $state(chan) QUIT {^221} quit_ok {} } thread_chainproc notifybl quit_ok {data} { thread_finish notifybl $id $state(okcode) } thread_chainproc notifybl timeout {} { thread_error notifybl $id "timed out" } work/rcpt-policy.tcl0000775000000000000000000001373515116102070011706 0ustar #!/usr/bin/tclsh # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: rcpt-policy.tcl,v 1.7 2003/09/07 23:34:29 ian Exp $ # userv service. Input is new user policy file, lines like: # # (and one line `.') Blank lines are permitted. Lines starting with # # are comments. # # is one of # [] # [/] # # # is one of # @ # (not ending in @) # (To match `<>' when specified as envelope sender, match `@' instead.) # # globs may contain no whitespace. They support [...], ? and * # and \-escapes. There is no way to specify patterns including # whitespace. # # is one of # 450|451|452|550|552|553 # normal|lax|nodelay|bait|unchecked proc log {lev msg} { puts stderr $msg } set @@@readlibs@@@ readlibs.tcl set sauce_libraries { readconf library sconfig } source ${@@@readlibs@@@} proc readconfig_posthook {args} {} readconfig if {[string length $current_bigerr]} { log fatal "configuration errors, stopping" exit 3 } cd $var_dir/policies proc fail {emsg} { puts stderr $emsg exit 1 } switch -exact [llength $argv] { 0 { set policy $env(USERV_USER) if {[info exists env(USERV_U_SUBPOLICY)]} { set subpolicy $env(USERV_U_SUBPOLICY) if {![string length $subpolicy]} { } elseif {[regexp -nocase {^\:[-+_.%$:0-9a-z?*]{0,188}$} \ $subpolicy subpolicy]} { append policy $subpolicy } else { fail \ "subpolicy must be : followed by 0-127 alphanumerics or : - + _ . % $ ? *" } } } 1 { set policy [lindex $argv 0] if {[regexp {/} $policy]} { fail "policy name may not contain /" } if {[regexp {^\.} $policy]} { fail "policy name may not start with ." } } default { fail "specify only one policy to set" } } set lno 0 set outtxt {} proc out {s} { global outtxt; append outtxt $s "\n" } out "proc acuser_proc/$policy {} {" proc syxerr {emsg} { global lno errorInfo fail "rcpt-policy: policy line $lno: error: $emsg" } proc out_once {text} { upvar #0 outonce_done($text) d if {[info exists d]} return out $text set d 1 } set encc 0 proc encvarn {thing} { upvar #0 enc_scope($thing) enc if {![info exists enc]} { global encc regsub -all {[^a-z]+} $thing _ p regsub -all {_+$} $p {} p regsub {^_} $p {U} p set enc "${p}_X[incr encc]" } return $enc } proc scope {thing} { set enc [encvarn $thing] out_once " upvar 1 $thing $enc" return "\$$enc" } proc condkind {kind argl rbody} { set body " upvar 1 \${condname}pat pat\n" append body " if {\"\$pat\" == \"*\"} return\n" append body $rbody proc cond_add_$kind [concat condname $argl] $body } condkind site {} { set len 32 if {[regexp {\[([0-9][0-9.]+)\]} $pat dummy mask] || \ [regexp {\[([0-9][0-9.]*)/([0-9]+)\]} $pat dummy mask len]} { out_once " set ra_v \[ia2value [scope state(ra)] 32\]" if {[catch { set re_v [ia2value $mask $len] } emsg]} { syxerr "invalid address: $emsg" } if {$len > 32} { syxerr "prefix length >32" } set ma_v [expr {$len == 0 ? 0 : ((0xffffffff<<(32-$len))&0xffffffff)}] set bad [expr {$re_v & ($ma_v ^ 0xffffffff)}] if {$bad} { syxerr "mask is non-zero beyond prefix" } cond_add "(\$ra_v & [format 0x%08x $ma_v]) == [format 0x%08x $re_v]" } elseif {[string match "\[*" $pat]} { syxerr "invalid address mask" } else { cond_add_glob $pat [scope state(rh)] } } proc cond_add_glob {pat valstring} { regexp {(.*)} $pat npat if {[catch { string match $npat foobar } emsg]} { syxerr "invalid glob pattern: $emsg" } cond_add "\[string match [list $npat] $valstring\]" } proc cond_add {cond} { global conds lappend conds $cond } condkind addr {lpv dmv} { if {[regexp {^(.*)\@$} $pat dummy lpat]} { cond_add_glob $lpat [scope $lpv] } else { set enc [encvarn $lpv@$dmv] out_once " set $enc [scope $lpv]@[scope $dmv]" cond_add_glob $pat \$$enc } } set condjoin " &&\n " set any 0 while 1 { if {[gets stdin line] < 0} { syxerr "missing final line `.'" } incr lno set line [string trim $line] if {![string length $line]} continue if {"$line" == "."} break if {[string match #* $line]} continue if {![regexp {^(\S+)\s+(\S+)\s+(\S+)\s+(\S.*\S)$} $line dummy \ sspat sapat rapat result]} { syxerr "syntax error" } set conds {} cond_add_site ss cond_add_addr sa state(mf_lp) state(mf_dm) cond_add_addr ra lp dm if {[llength $conds]} { out " if {[join $conds $condjoin]} \{" } if {![regexp \ {^(?:errok\-)?(45[012]|55[023]) \S.*$|^(?:errok\-)?(unchecked|lax|nodelay|normal|bait)$} \ $result]} { syxerr "invalid result" } if {[regexp -nocase {[^ -~]} $result]} { syxerr "invalid char in result" } out " [list return $result]" set any 1 if {[llength $conds]} { out " \}" } } out " return {}\n}" if {$any} { set out [open n$policy w] puts -nonewline $out $outtxt close $out file rename -force n$policy p$policy puts "ok - new SAUCE policy $policy installed" } else { file delete p$policy puts "ok - any SAUCE policy $policy removed" } work/readconf.tcl0000664000000000000000000001363315116102070011214 0ustar ########### readconf.tcl # Routines (part of controlling main program) for reading config file. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: readconf.tcl,v 1.16 2003/06/15 15:46:40 ian Exp $ set current_bigerr {} proc config_var {vn def type args} { global configvars set configvars($vn) [list $type $args] config_setvar $type $vn $def $args } proc config_nd {vn type args} { global configvars set configvars($vn) [list $type $args] } proc config_raw {vn body} { global configvars configvarsset set configvars($vn) [list raw $vn] proc config_rawset_$vn {value} $body set configvarsset($vn) 1 } proc config_setvar {type vn vv argl} { global configvarsset upvar #0 $vn var switch $type { raw { config_rawset_[lindex $argl 0] $vv } hlist { set subtype [lindex $argl 0] set subargl [lrange $argl 1 end] foreach le $vv { set var($le) [eval [list config_normalise_$subtype $le] $subargl] } } default { set var [eval [list config_normalise_$type $vv] $argl] } } set configvarsset($vn) 1 } proc config_normalise_port {vv} { if {[regexp {^0*([0-9]+)$} $vv dummy vr]} { return $vr } elseif {[regexp {^[a-z][-0-9a-z]*$} $vv]} { return $vv } else { error "invalid port" } } proc config_normalise_boolean {vv} { if {[regexp -nocase {^f|^n|^0$|^off} $vv]} { return 0 } elseif {[regexp -nocase {^t|^y|^1$|^on} $vv]} { return 1 } else { error "invalid boolean" } } proc config_normalise_filemode {vv} { if {[regexp -nocase {^[0-7][0-7][0-7]$} $vv]} { return [format 0%o 0$vv] } error "invalid file mode" } set unitlist_interval(ms) 1 set unitlist_interval(s) 1000 set unitlist_interval(m) 60000 set unitlist_interval(h) 3600000 set unitlist_interval(d) 86400000 set unitlist_elapsed(s) 1 set unitlist_elapsed(m) 60 set unitlist_elapsed(h) 3600 set unitlist_elapsed(d) 86400 set unitlist_elapsed(wk) 604800 set unitlist_elapsed(mth) 2629800 set unitlist_elapsed(yr) 31557600 set unitlist_size(b) 1 set unitlist_size(kb) 1024 set unitlist_size(mb) 1048576 proc cfnu_bare {vv} { upvar ul ul if {![regexp {^([.0-9]+)([a-z]+)$} $vv dummy mag un]} { error "value $vv not in form " } if {![info exists ul($un)]} { error "unit $un unknown; allowed are [lsort [array names ul]]" } set mag [expr $mag] set uv "$ul($un).0" return [expr {$mag*$uv}] } proc config_normalise_file {vv} { return $vv } proc config_normalise_printable {vv} { regexp {^"(.*)"[ \t]*$} $vv all vv return $vv } proc config_normalise_localpart {vv} { if {[regexp -nocase {[^-._+=%$0-9a-z]} $vv forb]} { error "localpart $vv contains forbidden character $forb" } return $vv } proc config_normalise_domain {vv} { if {[regexp -nocase {[^-.0-9a-z]} $vv forb]} { error "domain $vv contains forbidden character $forb" } return [string tolower $vv] } proc config_normalise_nicelocalpart {vv} { if {[regexp {[^-+_.0-9a-z]} $vv forb]} { error "local part $vv contains forbidden character $forb" } return [string tolower $vv] } proc config_normalise_number {vv min max} { if {![regexp {^[.0-9]+$} $vv mag]} { error "value $vv is not a correctly-formatted number" } return [expr {$mag+0}] } proc config_normalise_units {vv dim min max} { upvar #0 unitlist_$dim ul set actv [cfnu_bare $vv] set minv [cfnu_bare $min] set maxv [cfnu_bare $max] if {$actv < $minv || $actv > $maxv} { error "value $vv not in range $min..$max" } return [expr {round($actv)}] } proc config_err {emsg} { global current_bigerr log fatal $emsg set current_bigerr "Configuration error" } proc config_procsetvar {vn vv} { global configvars if {[info exists configvars($vn)]} { set cfv $configvars($vn) set type [lindex $cfv 0] set argl [lindex $cfv 1] config_setvar $type $vn $vv $argl } else { error "unknown configuration directive $vn" } } proc config_args {argv} { global real_argv set ix 0 set real_argv {} foreach ta $argv { if {![regexp -- {^-} $ta]} { set real_argv [lrange $argv $ix end] return } incr ix if {![regexp -- {^--([^=]+)=?(.*)$} $ta dummy vn vv]} { config_err "unknown option format $ta" continue } regsub -all -- - $vn _ vn if {[catch { config_procsetvar $vn $vv } emsg]} { config_err "command line:$ta:$emsg" } } } proc config_read {cf} { if {[catch { set fh [open $cf r] } emsg]} { config_err "unable to read config file: $emsg" return } if {[catch { set ln 0 while {[gets $fh l] >= 0} { incr ln if {[regexp {^#} $l] || ![regexp {[^ \t]} $l]} continue if {![regexp {^[ \t]*([_a-zA-Z]+)[ \t]*(.*)$} $l dummy vn vv]} { config_err "$cf:$ln:could not find valid config variable name" continue } if {[catch { config_procsetvar $vn [string trimright $vv] } emsg]} { config_err "$cf:$ln:$emsg" continue } } } emsg]} { config_err "$cf:reading:$emsg" } catch { close $fh } } proc config_checkmissing {} { global configvarsset config_file configvars foreach vn [array names configvars] { if {![info exists configvarsset($vn)]} { config_err "$config_file:no setting for $vn" } } } work/readlibs.tcl0000664000000000000000000000213215116102070011210 0ustar ########### readlibs.tcl # This file, when sourced, reads the library code files # specified in sauce_libraries. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: readlibs.tcl,v 1.7 2003/06/15 15:46:40 ian Exp $ set @@@share_dir@@@ . set @@@tcl_lib_ext?@@@ .tcl foreach x $sauce_libraries { source ${@@@share_dir@@@}/$x${@@@tcl_lib_ext?@@@} } work/sauce-await-startup.in0000775000000000000000000000037715116102070013166 0ustar #!/bin/sh # # Rather poor script to wait for sauce to start up. # # It would be better for these values not to be hardcoded, etc. set -e for s in 0.1 0.2 0.4 0.8 1.6 3.2; do if sauceadmin '' 2>/dev/null >/dev/null; then exit 0; fi sleep $s done work/sauce-bwlist.tcl0000775000000000000000000000604415116102070012036 0ustar #!/usr/bin/tclsh # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: sauce-bwlist.tcl,v 1.7 2003/06/15 15:46:40 ian Exp $ set @@@var_dir@@@ . set @@@sbin_dir@@@ . set @@@username@@@ ian proc usage {} { puts stdout \ {usage: sauce-bwlist [--force] --black|--white|--unknown --addr|--site []} } proc usageerr {emsg} { puts stderr "usage error: $emsg" usage exit 255 } proc nextarg {} { global argv set a [lindex $argv 0] set argv [lrange $argv 1 end] return $a } set force 0 set reasonprefix {} set type unset set newst unset while {[regexp {^--} [lindex $argv 0]]} { set a [nextarg] switch -exact -- $a { -- { break } --force { set force 1 } --addr { set type addr } --site { set type site } --black { set newst black } --unknown { set newst unknown } --white { set newst white } --userv { set type arg set newst arg set reasonprefix "$env(USERV_USER): " } default { usageerr "unknown option: $a" } } } proc checkarg {vn list} { upvar #0 $vn var if {"$var" == "arg"} { set a [nextarg] foreach x $list { if {"$a" == "$x"} { set var $x; return } } error "? $vn $a" } elseif {"$var" == "unset"} { usageerr "must specify --XYZ where XYZ is one of $list" } } checkarg type {addr site} checkarg newst {black white unknown} switch -exact [llength $argv] { 0 { usageerr "no entry given" } 1 { set reason "no reason given" } 2 { regexp {.*} [lindex $argv 1] reason } default { usageerr "too many arguments" } } regexp {.*} [lindex $argv 0] entry set reason $reasonprefix$reason if {[regexp {^[0-9]*[-&|@<>]} $entry meta]} { usageerr "entry contains metachars: $meta" } if {[catch { set f [open ${@@@var_dir@@@}/adminsecret r] } emsg]} { if {"[lrange $errorCode 0 1]" != "POSIX EACCES"} { error $emsg $errorInfo $errorCode } if {$force} { usageerr "privilege required to --force" } if {[catch { exec userv ${@@@username@@@} sauce-userblacklist \ $type $newst $entry " $reason" >@ stdout } emsg]} { puts stderr "requesting service via userv: $emsg"; exit 255 } } else { close $f set cmd [list userblacklist $type $newst $entry $force $reason] if {[catch { exec ${@@@sbin_dir@@@}/sauceadmin $cmd >@ stdout } emsg]} { puts stderr "executing sauceadmin: $emsg"; exit 255 } } work/sauce-firewall.in0000664000000000000000000000035615116102070012160 0ustar # This entry installed by SAUCE. if ( glob calling-user mail & glob service-user root ) no-suppress-args no-disconnect-hup null-fd 0 execute with-lock-ex -w ${@@@fw_lockfile@@@} \ ${@@@share_dir@@@}/firewall Sauce DENY -- fi work/sauce-rcptpolicy.in0000664000000000000000000000033615116102070012541 0ustar # This entry installed by SAUCE. if ( grep calling-user-shell /etc/shells & grep calling-user /etc/userlist & glob service-user mail ) suppress-args no-disconnect-hup execute ${@@@share_dir@@@}/rcpt-policy fi work/sauce-setsyspolicy.in0000775000000000000000000000065315116102070013130 0ustar #!/bin/sh badusage () { echo >&2 \ 'usage: sauce-setsyspolicy [:] [|-] default filename is ${@@@config_dir@@@}/policy[:]'; exit 1; } set -e case "$1" in :*) policy="$1"; subpolicy="$1"; shift ;; *) policy=:; subpolicy="" ;; esac case "$#.$1" in 0.) exec <${@@@config_dir@@@}/policy"$subpolicy" ;; 1.-) ;; 1.*) exec <"$1" ;; *) badusage ;; esac exec ${@@@share_dir@@@}/rcpt-policy "$policy" work/sauce-setuserpolicy.in0000775000000000000000000000061615116102070013267 0ustar #!/bin/sh badusage () { echo >&2 \ 'usage: sauce-setuserpolicy [:] [|-] default filename is ~/.sauce-policy[: 1 iff we are too busy (will then have called conn_err) global annoyance_toobusy annoy_grudge_max nstalls stalls_max global annoy_grumpy nconns busyfury_firewall if {$tcount <= $tmax} { return 0 } manyset [intern_getsiteannoy $ra $annoyance_toobusy] annoyval annoytype if {$busyfury_firewall==1 && $annoyval == $annoy_grudge_max} { bff_add $ra } set explain \ "$msg ($tcount/$tmax $annoyval) \[[irrit_present $annoytype]\]" if {$nstalls < $stalls_max && $annoyval > $annoy_grumpy} { decr_conncount nconns $ra incr_conncount nstalls $ra set thread [thread_start stall $desc-stall $ra $chan $explain] thread_join {} {} stall $thread conn_done conn_err \ nstalls $chan $ra $lh "Internal error in stall" } else { conn_err nconns $chan $ra $lh $explain {} if {$busyfury_firewall==2} { bff_add $ra } } return 1 } proc new_conn {chan ra rp} { global ipaddr_phase_proportion ipaddr_phase_offset local_interface current_bigerr global nconns conns_max annoy_love_max annoy_grudge_max if {[catch { if {$ipaddr_phase_proportion < 256 && \ ![info exists local_interface($ra)]} { set cp $ipaddr_phase_offset foreach tb [split $ra .] fc {3 23 73 131} { set cp [expr {($cp+$tb*$fc)%256}] } if {$cp < $ipaddr_phase_proportion} { log notice "$ra connected, phase $cp < $ipaddr_phase_proportion" } else { log notice "$ra connected, phase $cp >= $ipaddr_phase_proportion, twisting" fconfigure $chan -blocking true exec <@ $chan >@ $chan sh -c { sendmail -bs <&1 & } return } } set lalhlp [fconfigure $chan -sockname] fconfigure $chan -translation {binary crlf} -blocking false } emsg]} { if {[string length $emsg]} { log error "get local address: $emsg" } catch { close $chan } } else { set lh [lindex $lalhlp 1] set desc "$lh-$ra:$rp" if {$ipaddr_phase_proportion == 256} { debug0 1 "$desc connected" } set acra [incr_conncount nconns $ra] chanset_desc $chan $desc if {[thread_shuttingdown]} { conn_err nconns $chan $ra $lh "Shutting down" {} } elseif {[string length $current_bigerr]} { conn_err nconns $chan $ra $lh $current_bigerr {} set current_bigerr {} readconfig reopenlogs } else { manyset [intern_getsiteannoy $ra 0] annoyval annoytype if {$annoyval > 0} { set tmax [expr {int( double($conns_max) * pow(0.25, sqrt(double($annoyval) / double($annoy_grudge_max))) )}] if {[new_conn_checkbusy $chan $ra $lh $desc $nconns $tmax \ "Too busy"]} return } set tmax [expr {int( double($conns_max) * -double($annoyval) / double($annoy_love_max) )}] if {$acra>1 && \ [new_conn_checkbusy $chan $ra $lh $desc $acra $tmax \ "Excessive concurrency"]} return set thread [thread_start ic $desc $chan $lalhlp $ra $rp] thread_join {} {} ic $thread conn_done conn_err \ nconns $chan $ra $lh "Internal error" } } } proc bff_log {addr how} { log reject "firewall addr=$addr $how" } proc bff_add {addr} { global busyfury_firewall busyfury_firewall_time bff_addrs if {!$busyfury_firewall || !$busyfury_firewall_time} return if {[info exists bff_addrs($addr)]} return set bff_addrs($addr) [after $busyfury_firewall_time bff_expire $addr] bff_log $addr deny bff_setup } proc bff_expire {addr} { global bff_addrs unset bff_addrs($addr) bff_log $addr accept bff_setup } proc bff_setup {} { global busyfury_firewall bff_addrs firewall_command if {!$busyfury_firewall} return set addrs [array names bff_addrs] set cmd [concat [list $firewall_command < /dev/null] $addrs] if {[catch { eval exec $cmd } emsg]} { log error "unable to set firewall state: $emsg" } else { set result [split $emsg "\n"] foreach l $result { log debug "set firewall: $l" } } } proc globalavfpool_start {} { global avfpoolid set avfpoolid [thread_start avfpool avfpool] thread_join {} {} avfpool $avfpoolid globalavfpool_done globalavfpool_done } proc globalavfpool_done {args} { log error "avfpool done ! report: $args" globalavfpool_start } proc setstate {type entry why args} { global var_dir errorInfo errorCode log dbreasons [list $type $entry [lindex $args 0] $why] eval [list ds_set $type-list $entry] $args } proc databases_init {} { global var_dir global initdb_file foreach what {addr site} \ re {{^(black|white|whitesoon|verified)$} {^(black|white|whitesoon)$}} \ doquote {1 0} { ds_bind $what-list $var_dir/cdb.$what-list $re $doquote ds_bind $what-seen $var_dir/cdb.$what-seen {^\d+$} $doquote } ds_bind site-annoy $var_dir/cdb.site-annoy {^\d+am?\d+$} 0 set f [open $initdb_file r] set lno 0 while {[gets $f l] != -1} { incr lno if {[regexp {^\#} $l]} { continue } if {![regexp {^(site|addr)\s+(white|black)\s+(.*\S)\s*$} \ $l dummy type state keyquoted]} { error "$filename:$lno:bad format in blacklist/whitelist config" } set key [subst -nocommands -novariables $keyquoted] ds_setforever $type-list $key $state } close $f } if {[catch { if {[llength $real_argv]} { error "please supply no non-option arguments" } reopenlogs if {[file writable /]} { error "do not run sauce as root; use something like authbind instead" } databases_init } emsg]} { if {![string length $current_bigerr]} { log fatal "error starting up: $emsg ($errorInfo)" set current_bigerr "Error starting up" } } if {[string length $current_bigerr]} { log fatal "fatal errors, stopping ($current_bigerr)"; exit 1 } set adminsecret {} globalavfpool_start if {[catch { if {[array size local_interface]} { foreach li [array names local_interface] { socket -myaddr $li -server new_conn $port } } else { socket -server new_conn $port } thread_start adminsecret admin-secret bff_setup log notice started if {![info exists asynch_script]} { vwait quit_now } } emsg]} { log fatal "main program returned error: $emsg, $errorInfo" } work/sauce9-convert.in0000775000000000000000000000200115116102070012114 0ustar #!/bin/sh set -e fail () { echo >&2 "$*"; exit 16; } if [ "$#" != 1 ]; then fail 'usage: sauce9-convert ' fi echo "Checking for SAUCE databases in $1 ..." cd "$1" umask 022 rm -f tmp-cdb.* for db in site-annoy site-seen site-list \ addr-seen addr-list do printf " %s " "cdb.$db" todelete=`find . -maxdepth 1 \ \( -name 'db.*.*' -o -name 'cdb.*' \) \ -mtime +28 -type f -print` if [ "x$todelete" != x ]; then echo -n "("deleting stale $todelete") " rm -- $todelete fi if test -f cdb.$db.main; then echo " new database exists, not converting." continue fi inputs=`find . -maxdepth 1 \ \( -name "db.$db.main" -o -name "db.$db.log" \) \ -print` if [ "x$inputs" != x ]; then echo -n "("reading $inputs") " else printf "(no existing data) " fi ${SAUCE_CONVERTDB:-${@@@share_dir@@@}/convertdb} \ tmp-cdb.$db 0 $inputs >/dev/null printf " done" for g in lock main jrn cdb; do chown mail:mail tmp-cdb.$db.$g mv -f tmp-cdb.$db.$g cdb.$db.$g done echo . done work/sauceadmin.tcl0000775000000000000000000000767115116102070011554 0ustar #!/usr/bin/tclsh # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: sauceadmin.tcl,v 1.16 2003/06/15 15:46:40 ian Exp $ load chiark_tcl_crypto-1.so proc log {lev msg} { puts stderr $msg } set @@@readlibs@@@ readlibs.tcl set sauce_libraries { readconf sconfig } source ${@@@readlibs@@@} proc readconfig_posthook {args} {} readconfig if {[string length $current_bigerr]} { log fatal "configuration errors, stopping" exit 3 } set interfaces [array names local_interface] if {![llength $interfaces]} { set interfaces 127.0.0.1 } set tries [llength $interfaces] if {$tries < 4} { set tries 4 } set connected 0 set errorred 0 while {!$connected} { if {![llength $interfaces]} { if {!$errorred} { exit 1 } puts stderr "no interfaces left to try"; exit 2 } set if [lindex $interfaces 0] set interfaces [lrange $interfaces 1 end] if {[catch { set sock [socket $if $port] } emsg]} { if {$sauceadmin_connrefused_ok && "[lindex $errorCode 0]" == "POSIX" && "[lindex $errorCode 1]" == "ECONNREFUSED"} { continue } set errored 1 puts stderr "$if: $emsg" continue } if {[catch { fconfigure $sock -buffering line -translation {crlf crlf} gets $sock banner if {![regexp {^220} $banner]} { error "banner => $banner" } puts $sock SAUCEADMIN gets $sock chalstr if {![regexp {^393[ \t]+([0-9a-f]+)\r?$} $chalstr all chal]} { error "SAUCEADMIN => $chalstr" } set sfile [open $var_dir/adminsecret r] set secret [read $sfile] close $sfile; unset sfile set resp [hbcrypto hash sha256 "$chal$secret"] puts $sock "SAUCEADMIN $chal $resp" gets $sock okstr if {![regexp {^294|^4[0-9][0-9]} $okstr]} { error "SAUCEADMIN => $okstr" } } emsg]} { set errored 1 puts stderr "$if: $emsg" catch { close $sfile; unset sfile } catch { close $sock; unset sock } continue } if {[regexp {^294} $okstr]} { set connected 1 } else { set errored 1 puts stderr "$if: SAUCEADMIN => $okstr" incr tries -1 if {$tries <= 0} { puts stderr "too many retries"; exit 2 } exec sleep 4 lappend interfaces $if } } if {[llength $real_argv]} { fconfigure $sock -buffering none puts $sock ";" gets $sock x if {"$x" != "% "} { puts stderr "startup: `$x'"; exit 2 } foreach cmd $real_argv { gets $sock x if {"$x" != "EOP"} { puts stderr "before $cmd: `$x'"; exit 2 } puts $sock "$cmd\n;" set op "\n" while 1 { gets $sock x if {"$x" == "EOP"} break if {![string length $x] && [eof $sock]} { if {"$cmd" == "shutdown"} { exit 0 } puts stderr "after $cmd: eof" exit 2 } append op "$x\n" } regsub {\n\% \n} $op "\n" op regsub {^\n} $op {} op puts -nonewline $op puts $sock ";" gets $sock x if {"$x" != ""} { puts stderr "after $cmd: `$x'"; exit 2 } } exit 0 } proc copydata {in out} { set d [read $in] if {![string length $d] && [eof $in]} { puts " disconnected" exit 0 } puts -nonewline $out $d } fconfigure stdin -blocking false -buffering none fconfigure stdout -blocking false -buffering none fconfigure $sock -blocking false -buffering none fileevent stdin readable [list copydata stdin $sock] fileevent $sock readable [list copydata $sock stdout] vwait unused work/sconfig.tcl0000664000000000000000000003062215116102070011060 0ustar ########### sconfig.tcl # Config variables for SAUCE and their defaults. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: sconfig.tcl,v 1.49.2.1 2008/03/08 15:34:31 ian Exp $ set @@@var_dir@@@ . set @@@log_dir@@@ . set @@@config_dir@@@ . proc config_normalise_busyfury_firewall {vv} { if {[regexp -nocase {^i|^2} $vv]} { return 2 } else { return [config_normalise_boolean $vv] } } config_var ident_port ident port config_var port 25 port config_var remote_port smtp port config_var always_blacklist_site false boolean config_var blacklist_all_addresses false boolean config_var blacklist_on_bounces false boolean config_var conns_max 120 number 1 10000 config_var stalls_max 300 number 0 10000 config_var taboo_virus_hack false boolean config_var ident_timeout 60s units interval 0ms 5m config_var fail_send_timeout 1s units interval 0ms 5m config_var command_timeout 5m units interval 0ms 1h config_var wholedata_timeout 30m units interval 0ms 12h config_var verify_perconn_timeout 130s units interval 0ms 5m config_var verify_all_timeout 270s units interval 0ms 15m config_var verify_cache_timeout 60s units interval 0ms 7d config_var verify_reuse_timeout 4m units interval 0ms 1h config_var verify_rset_timeout 2m units interval 0ms 5m config_var verify_quit_timeout 12s units interval 0ms 5m config_var notifybl_timeout 15m units interval 0ms 1h config_var annoy_halflife 5h units elapsed 1s 1wk config_var annoy_grudge_max 15m units interval 0ms 3h config_var annoy_love_max 15m units interval 0ms 3h config_var annoy_actout_max 150s units interval 0ms 5m config_var annoy_actout_nopartresp 60s units interval 0ms 5m config_var annoy_grumpy 300s units interval 0ms 3h config_var annoy_partrespevery 30s units interval 0ms 10m config_var pleasure_command 1s units interval 0ms 10m config_var pleasure_delivery 60s units interval 0ms 10m config_var annoyance_toobusy 5s units interval 0ms 10m config_var annoyance_minor 5s units interval 0ms 10m config_var annoyance_major 30s units interval 0ms 10m config_var stall_interval 50s units interval 1s 1h config_var stall_count 216 number 1 1000000 config_var busyfury_firewall immed busyfury_firewall config_var busyfury_firewall_time 30m units interval 0ms 72h config_var addr_whitelist_delay 5d units elapsed 0s 2mth config_var site_whitelist_delay 5d units elapsed 0s 2mth config_var addr_whitelist_timeout 2mth units elapsed 1m 30yr config_var site_whitelist_timeout 2mth units elapsed 1m 30yr config_var addr_verified_timeout 30d units elapsed 0s 30yr config_var site_verified_timeout 30d units elapsed 0s 30yr config_var addr_blacklist_timeout 7d units elapsed 1m 30yr config_var site_blacklist_timeout 12mth units elapsed 1m 30yr config_var new_addr_defer 1h units elapsed 0s 3d config_var new_site_defer 3h units elapsed 0s 3d config_var remember_addr_defer 2mth units elapsed 0s 1yr config_var remember_site_defer 2mth units elapsed 0s 1yr config_var admin_chal_timeout 30s units elapsed 5s 15m config_var admin_secret_refresh 4h units interval 1m 7d config_var admin_secret_length 32 number 16 64 config_var force_shutdown_delay 30s units interval 1s 2h config_var max_header_size 100kb units size 10kb 10mb config_var max_smtpparms_size 10kb units size 1kb 100kb config_var max_verify_rcpts 10 number 1 100 config_var max_smtp_errors 30 number 1 300 config_var ipaddr_phase_proportion 256 number 0 256 config_var ipaddr_phase_offset 0 number 0 255 config_var mixedkinds_message "Mixed recipient kinds, try this one later" printable config_var bland_message "Recipient verified" printable config_var bouncedjunk_message "Bounce of probably-forged junk mail" printable config_var blacklist_message "You are blacklisted - contact postmaster." printable config_var blacknone_message "Message blacklisted - contact postmaster." printable config_var blacksite_message "Your site is blacklisted - contact postmaster." printable config_var rbl_reject_message "Your site is realtime-blacklisted (%d: %m)" printable config_var rbl_defer_message "Site distrusted, try later (%d: %m)" printable config_var new_addr_message "Sender not yet trusted, try later" printable config_var new_site_message "Site not yet trusted, try later" printable config_nd local_domain hlist domain config_nd local_interface hlist domain config_var canonical_hostname [info hostname] domain config_var notifybl_localpart sauce-daemon nicelocalpart config_var admin_localpart sauce-admin nicelocalpart config_var notifybl_bounces sauce-bounces nicelocalpart config_var allow_saucestate false boolean config_var add_received true boolean config_var add_warnings true boolean config_var require_reverse_dns true boolean config_var forbid_helo_ipliteral true boolean config_var check_helo_name false boolean # ... violates a MUST NOT in RFC1123 config_var require_callingmaildomain_name true boolean config_var require_callingmaildomain_dnsok true boolean config_var require_messageid false boolean config_var sauceadmin_connrefused_ok false boolean config_var log_mode 644 filemode config_var log_mode_debug 640 filemode config_var log_stderr false boolean config_var debug_level 0 number 0 9999 config_var var_dir ${@@@var_dir@@@} file config_var log_dir ${@@@log_dir@@@} file config_var config_dir ${@@@config_dir@@@} file config_var config_file config file config_var initdb_file db.manual file config_var blmessage_site_file blmessage-site.text file config_var blmessage_addr_file /dev/null file config_var policies_dir policies file config_var firewall_command set-firewall file config_var blmessage_sendmail_args {} printable config_var adns_options {} printable config_var irritated_tell_submissive Submissive printable config_var irritated_tell_ecstatic Ecstatic printable config_var irritated_tell_pleased Pleased printable config_var irritated_tell_irritated Irritated printable config_var irritated_tell_angry Angry printable config_var irritated_tell_furious Furious printable # CARE! We completely trust policies/p$user, so whatever puts things # there must translate the user's input into something suitable. # This is what rcpt-policy.tcl is for. config_raw anger_stallwith { global fill_msgs foreach l [split [config_normalise_printable $value] "\n"] { lappend fill_msgs $l } } config_raw rbl { global rbls rbl_reject_message rbl_defer_message if {![regexp -nocase \ {^([-+.0-9a-z]+)[ \t]+(reject|\d+[a-z]+[ \t]+\d+[a-z]+)[ \t]*(.*)$} \ $value dummy dm what msg]} { error "rbl takes value ` reject \[\]' or ` \[\]'" } set dm [config_normalise_domain $dm] set reject [expr {"[string tolower $what]" == "reject"}] if {$reject} { set ifnewaddr {} set ifnewsite {} } else { set ifnewaddr [config_normalise_units [lindex $what 0] elapsed 0s 3d] set ifnewsite [config_normalise_units [lindex $what 1] elapsed 0s 3d] } if {[string length $msg]} { set msg [config_normalise_printable $msg] } elseif {$reject} { set msg $rbl_reject_message } else { set msg $rbl_defer_message } lappend rbls [list $dm $ifnewaddr $ifnewsite $msg] } config_raw addr_regexps_nodefault { global addr_patterns if {[string length $value]} { error "addr_regexps_nodefault takes no value" } set addr_patterns {} } config_raw addr_regexp { global addr_patterns if {![regexp -- {^/(.*)/\s+([a-z]+[^/]*)$} $value dummy ap at] && \ ![regexp -- {^([^/ \t]\S*)\s+([a-z]+.*)$} $value dummy ap at]} { error "addr_regexp takes value ` ' or \ `// '" } switch -regexp $at { (errok-)?unchecked - (errok-)?lax - (errok-)?nodelay - (errok-)?normal - (errok-)?bait - {(errok-)?45[012] \S.*} - {(errok-)?55[023] \S.*} - policy - user - {user=.*} { } * { error "addr_regexp type must be one of \ \[errok-\]unchecked, \[errok-\]lax, \[errok-\]nodelay, \ \[errok-\]normal, \[errok-\]bait, \ policy, user, user=, \ \[errok-\]450|451|452|550|552|553 (or with addr_pattern, bypass or admin)" } } regexp -- $ap {} lappend addr_patterns [list $at $ap] } config_raw addr_patterns_nodefault { config_procsetvar addr_regexps_nodefault $value } config_raw addr_pattern { if {![regexp -- {^([a-z]+)[ \t]+(.+)$} $value dummy at re]} { error "addr_pattern takes value ` ' or \ ` //" } switch -exact $at { bypass { set at lax } admin { set at unchecked } } config_procsetvar addr_regexp "$re $at" } proc reset_config {} { global addr_patterns fill_msgs rbls set addr_patterns { {policy .*} {unchecked sauce-admin@} {unchecked postmaster@} {bait bait@} } catch { unset fill_msgs } set rbls {} } reset_config proc qualify_filename {fnvar dir} { upvar #0 $fnvar fn if {[regexp {^/} $fn]} { return } set fn "$dir/$fn" } proc readconfig {} { global argv current_bigerr config_dir var_dir global config_file policies_dir global site_whitelist_delay addr_whitelist_delay global ipaddr_phase_proportion local_interface reset_config config_args $argv qualify_filename config_file $config_dir config_read $config_file if {![string length $current_bigerr]} { config_args $argv } qualify_filename initdb_file $config_dir qualify_filename firewall_command $config_dir qualify_filename policies_dir $var_dir foreach sa {addr site} { global blmessage_$sa blmessage_${sa}_file qualify_filename blmessage_${sa}_file $config_dir set blf [set blmessage_${sa}_file] if {[catch { set blm [open $blf r] set blmsg [read $blm] close $blm regsub {\n\.} $blmsg {\n..} blmessage_$sa } emsg]} { config_err "$blf:$emsg" catch { close $blm } } } config_checkmissing if {$ipaddr_phase_proportion < 256 && ![array size local_interface]} { set ipaddr_phase_proportion 256 config_err "ipaddr_phase_proportion used, but local_interfaces not explicit" } readconfig_posthook } proc irrit_present {irritamt} { upvar #0 irritated_tell_[string tolower $irritamt] tell return $tell } work/setsettings.tcl0000664000000000000000000000204715116102070012004 0ustar ########### setsettings.tcl # Formats settings into file on stdout. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: setsettings.tcl,v 1.6 2003/06/15 15:46:40 ian Exp $ source instlib.tcl foreach {s v} $argv { set v [string_quote $v 0] puts [format {set %-20s %s} $s $v] } flush stdout work/smtp.tcl0000664000000000000000000011416515116102070010420 0ustar ########### smtp.tcl # # Main SMTP protocol implementation # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: smtp.tcl,v 1.22.2.3 2008/03/08 17:29:37 ian Exp $ ########## connection threads # thread_start $chan $desc $remoteaddr $remoteport # # errors/results ignored # # state variables: # # Always set: # chan incoming SMTP connection # ra calling IP address # rp calling port # rh calling hostname (or IP-literal), available only after HELO # la called (local) address # lh called (local) canonical hostname for interface # lp called (local) port # rcptcounter counter of total no of RCPTs issued in session, for logging # smtpcmd SMTP command we are processing, or empty string # smtpreaderr Last system error reading from incoming SMTP connection # rej_conn list of connection-wide rejection reasons (or {}) # defer_conn deferral reasons (defer_* takes precedence over rej_*) # none of these reasons may contain "\n" # smtperrors count of SMTP error responses # quitting set => we have been asked to shut down # Generally useful # avfid ID of current address verification thread (unset => none) # dnsid thread for forward DNS lookups (unset => none) # dnsptrid thread for reverse DNS lookup (unset => none) # lastchal last challenge sent on this conn for SAUCEADMIN # rbl_hits list of RBL domains we've hit # Used during connection setup, but not changed afterwards: # cmdomain calling host's mail domain to report to # ident result of ident lookup (whether informative or error) # ichan reverse ident lookup connection (unset => none) # itoid timeout for ident lookup or incoming command (unset=>none) # Only set after HELO # helostring set => we have had helo/ehlo, and this was what they said # this implies mtachan being open and connected # smtpstyle `smtp' or `esmtp'. # mtachan channel to local MTA # helocmd the command helo or ehlo that they used # heloexts list of extensions we advertised in response to EHLO # Only set after MAIL FROM; unset/reset for new messages: # ([re]set by ic_msg_resetvars) # rej_msg list of reasons why we're rejecting this message # defer_msg list of reasons why we're deferring this message # (only ever set before we get to DATA to avoid late defer) # delay_msg set => we want to defer because of an RBL or newness &c # att_rcpts list of recipients they've asked for (perhaps not got) # each entry is list: $class $rcpt $respcoode # mf_lp set => we have had MAIL FROM, and this is the local part # mf_dm MAIL FROM domain, may be garbage or unset if mf_lp not set # a_kinds list of recip kinds we've accepted (unchecked/normal/bait) # we only allow ourselves to get into the following states: # none unchecked normal bait unchecked+bait normal+bait # and the same +lax (but avoid accepting normal after bait) # for this var, nodelay addrs are normal. Repeats allowed. # mf_parms parameters to MAIL FROM, if any # rcpts_errok_only unset: no RCPT commands attempted since RSET # 0: at least one RCPT attempted since RSET wasn't errok # 1: all RCPTs (and there were some) were errok # add_bl list of reasons to blacklist everyone to do with this msg # none may contain newline # Used/set while processing message body ([re]set by ic_msg_resetvars) # header accumulated header text # currenthn name of header field we're currently in # currenthl value of header field we're currently in, including name # mid value of Message-ID header field # resentmids list of Resent-Message-ID's ({} => none) # resentany 1 => we have had a Resent- field, 0 => we haven't # hdrscomplete we have received and stored all the headers (that we # are going to parse); now finish verifs & do body (unset/1) # originators List of origs we've seen (incl. env & headers) & checked # originators_tochk Originators seen but not yet checked (with avf) # (both in dequoted form), as [list $lp $dm $headername] # Recipient delay: # We can delay if we get mail from unknown senders or unknown hosts. # The delay period can be increased if the sending host is RBLd. # So: both sender and host on whitelist => no delay, no RBL lookup. # Otherwise, do RBL lookup. Sending host RBLd for reject => reject. # Otherwise, delay until BOTH # first contact from this site was at least minimum site delay ago # first contact from this sender was at least minimum sender delay ago # (minimum is calculated across all applicable RBLs, and new # site or sender delay). # # mf_message proposed success message for MAIL FROM # rblids RBL lookups in progress (or empty list) # minsiteage min time (secs) since first contact with site, or we delay # minaddrage min time (secs) since first contact with addr, or we delay # mf_lp, mf_dm set thread_typedefine ic {chan lalhlp ra rp} { global ident_port ident_timeout chan_desc set state(chan) $chan set state(ra) $ra set state(rp) $rp manyset $lalhlp state(la) state(lh) state(lp) set state(smtpcmd) {} set state(smtpreaderr) {} set state(rej_conn) {} set state(defer_conn) {} set state(smtperrors) 0 set state(rcptcounter) 0 set state(rbl_hits) {} set state(rblids) {} ic_msg_resetvars set state(dnsptrid) \ [thread_start dnsptr "$state(desc) / reverse lookup" $ra] if {[catch { set state(ichan) [socket -myaddr $state(la) -async \ $state(ra) $ident_port] chanset_desc $state(ichan) "$state(desc) / ident" } emsg]} { log notice "ident error connecting to $ra: $emsg" ic_ident_done {} } else { fconfigure $state(ichan) -translation {binary crlf} -blocking false fconfigure $state(ichan) -encoding binary set state(itoid) [thread_after ic $id $ident_timeout ident_timeout] thread_fileevent ic $id $state(ichan) writable ident_connected } } { global canonical_hostname set state(quitting) 1 if {![info exists state(header)] && ![info exists state(sofar)]} { catch_close_cleardesc state(mtachan) ic_commandfinalresponse immed "421 $canonical_hostname shutting down" } } { ic_kill_subthreads catch { fileevent $state(chan) readable {} } catch { fileevent $state(chan) writable {} } catch_close_cleardesc state(mtachan) } thread_subproc ic kill_subthreads {} { foreach thr $state(rblids) { catch { thread_cancel dns $thr } } set state(rblids) {} catch_close_cleardesc state(ichan) catch { thread_cancel dnsptr $state(dnsptrid) } catch { thread_cancel avf $state(avfid) } ic_unsetcommandresponsetimeout catch { after cancel $state(ptoid) } catch { unset state(ptoid) } } thread_subproc ic unsetcommandresponsetimeout {args} { catch { after cancel $state(itoid) } catch { unset state(itoid) } } thread_chainproc ic ident_timeout {} { unset state(itoid) log notice "ident timeout on $state(ra)" ic_ident_done {} } thread_chainproc ic ident_connected {} { threadio_putsgets ic $id $state(ichan) "$state(rp) , $state(lp)\n" \ ident_rx_ok ident_rx_err } thread_chainproc ic ident_rx_ok {data} { global annoyance_major after cancel $state(itoid) unset state(itoid) set eof [eof $state(ichan)] regexp {^.*} $data data if {$eof} { log notice "ident eof on $state(ra)" ic_ident_done {} } elseif {[regexp -nocase {^[ \t]*[0-9]+[ \t]*,[ \t]*[0-9]+[ \t]*:[ \t]*userid[ \t]*:[^:]*:([^:]*)$} $data all userid]} { ic_ident_done [string trim $userid] } elseif {[regexp -nocase {^[ \t]*[0-9]+[ \t]*,[ \t]*[0-9]+[ \t]*:[ \t]*error[ \t]*:(.*)$} $data all error]} { log notice "ident remote error on $state(ra): [string trim $error]" ic_ident_done {} } else { manyset [ic_getsiteannoy $annoyance_major] cv irritamt log notice "ident gave garbage on $state(ra)\ ([string tolower $irritamt]=${cv}ms):\ [string trim $data]" ic_ident_done {} } } thread_chainproc ic ident_rx_err {emsg} { log debug "ident failed on $state(ra): $emsg" ic_ident_done {} } thread_subproc ic ident_done {ident} { catch_close_cleardesc state(ichan) catch { after cancel $state(itoid) } catch { unset state(itoid) } set state(ident) $ident thread_join ic $id dnsptr $state(dnsptrid) remotedns_ok remotedns_err } thread_chainproc ic remotedns_ok {answers emsgstr} { global require_reverse_dns if {[llength $answers]} { ic_remotedns_done [join $answers] } else { if {$require_reverse_dns} { lappend state(rej_conn) "reverse DNS: $state(ra): $emsgstr" } ic_remotedns_done "\[$state(ra)\]" } } thread_chainproc ic remotedns_err {emsg} { global require_reverse_dns if {$require_reverse_dns} { lappend state(defer_conn) "reverse DNS: $state(ra): [singleline $emsg]" } ic_remotedns_done "\[$state(ra)\]" } thread_subproc ic remotedns_done {dnsresult} { global canonical_hostname unset state(dnsptrid) set state(rh) $dnsresult ic_commandresponse_maybefinal greeting -1 \ "220 $canonical_hostname sauce-smtpd ESMTP ready" } thread_subproc ic commandresponse {evtype response} { ic_commandresponse_maybefinal $evtype 0 $response } proc intern_getsiteannoy {ra change} { global annoy_halflife annoy_grudge_max annoy_love_max global annoy_grumpy annoy_actout_max local_interface if {[info exists local_interface($ra)]} { return [list -$annoy_love_max Submissive] } set ca [ds_get site-annoy $ra] set now [clock seconds] if {"$ca" == "unknown"} { set cv 0 } else { manyset [string map {a { } m -} $ca] ct cv set newcv [expr { round( floor( $cv * pow( 0.5, double($now-$ct)/$annoy_halflife ) )) }] debug 2 cv=$cv now=$now ct=$ct hl=$annoy_halflife newcv=$newcv set cv $newcv } incr cv $change if {$cv > $annoy_grudge_max} { set cv $annoy_grudge_max } if {$cv < -$annoy_love_max} { set cv -$annoy_love_max } ds_set site-annoy $ra \ [string map {{ } a - m} [list $now $cv]] \ [expr {3*$annoy_halflife}] if {$cv <= -$annoy_love_max/2 && $cv <= -($annoy_grumpy+$annoy_actout_max)} { set irritamt Ecstatic } elseif {$cv <= 0} { set irritamt Pleased } elseif {$cv <= $annoy_grumpy} { set irritamt Irritated } elseif {$cv <= $annoy_grumpy+$annoy_actout_max} { set irritamt Angry } else { set irritamt Furious } return [list $cv $irritamt] } thread_subproc ic getsiteannoy {change} { return [intern_getsiteannoy $state(ra) $change] } thread_subproc ic commandresponse_maybefinal {evtype final response} { # final==-1 means initial (used because then we have to prefix # each stalling line); final==0 means normal; final==1 means final. global max_smtp_errors canonical_hostname global annoy_actout_max annoy_grumpy annoy_partrespevery annoy_actout_nopartresp global pleasure_command pleasure_delivery annoyance_major annoyance_minor if {"$evtype" != "immed" && [ic_check_quitting]} { return } switch -exact $evtype { command - delivery { set annoychange -[set pleasure_$evtype] } nopartresp { set annoychange -$pleasure_command } major - minor { set annoychange [set annoyance_$evtype] } rcpt-defer { set annoychange $annoyance_minor } immed - greeting { set annoychange 0 } default { error "$evtype ?" } } if {[info exists state(rcpts_errok_only)] && $state(rcpts_errok_only)} { set min_delay $annoychange # We always apply some teergrube here, regardless of whether # we're angry, just to make sure we can't get into a high-speed spin. set annoychange [expr {-abs($annoychange)}] } manyset [ic_getsiteannoy $annoychange] cv irritamt switch -exact $evtype { major - minor - rcpt-defer { set delay $cv incr state(smtperrors) if {$final<=0 && $state(smtperrors) > $max_smtp_errors} { log notice "too many errors from $state(rh), closing channel (annoy=$cv)" ic_commandfinalresponse major \ "421 $canonical_hostname $response \[too many errors\]" return } } command { set delay [expr {$cv - $annoy_grumpy}] } nopartresp - greeting { set delay [expr {$cv - $annoy_grumpy}] if {$delay > $annoy_actout_nopartresp} { set delay $annoy_actout_nopartresp } } delivery - immed { set delay 0 } default { error "$evtype ?" } } set irritpresent [irrit_present $irritamt] set irritval "${cv}ms" if {[info exists min_delay]} { if {$delay < $min_delay} { set delay $min_delay } append irritval - append irritpresent - } set irritamtl [string tolower $irritamt] if {$delay > $annoy_actout_max} { set delay $annoy_actout_max } switch -exact $evtype { major { logreject reject state command $response $irritamtl $irritval } minor { if {$delay > 0} { logreject notice state delay $response $irritamtl $irritval } } rcpt-defer { logreject notice state rcpt-defer {} $irritamtl $irritval } command - delivery - nopartresp - greeting - immed { } default { error "$evtype ?" } } if {[string length $response]} { if {$delay > 0 || "$evtype" == "greeting"} { regsub {(?m)$} $response " \[$irritpresent\]" response } } else { set delay 0 } ic_commandresponsedelay $delay [expr {"$evtype" == "nopartresp"}] \ $final $response 0 } thread_subproc ic commandresponsedelay {delay nopartresp final response f_ix} { global command_timeout global annoy_partrespevery if {$final<=0 && [ic_check_quitting]} { return } if {!$nopartresp && $delay > $annoy_partrespevery} { incr delay -$annoy_partrespevery set state(ptoid) [thread_after ic $id $annoy_partrespevery \ commandresponsedelay_part $delay $final $response $f_ix] return } elseif {$delay > 0} { set state(ptoid) [thread_after ic $id $delay \ commandresponsedelay_after $final $response] return } chanset_hide $state(chan) 1 1 if {[string length $response]} { append response "\n" } set state(smtpcmd) {} set state(smtpreaderr) {} if {$final>0} { chanset_hide $state(chan) 1 1 ic_setresponsetimeout threadio_puts ic $id $state(chan) $response tellquit_done tellquit_done } else { ic_setcommandtimeout threadio_putsgets ic $id $state(chan) $response command_ok command_err } } thread_subproc ic setcommandtimeout {} { global command_timeout set state(itoid) [thread_after ic $id $command_timeout timedout] } thread_chainproc ic commandresponsedelay_part {delay final response f_ix} { global canonical_hostname fill_msgs if {[regexp {^([0-9][0-9][0-9]\-[^\n]*)\n(.*)$} $response dummy \ thisline remainder]} { } elseif {[regexp {^([0-9][0-9][0-9])\s([^\n]*)} $response dummy \ code rhs]} { set thisline "$code-$rhs" set remainder "$code " if {$final!=0} { append remainder "$canonical_hostname " } append remainder [lindex $fill_msgs $f_ix] set f_ix [expr {($f_ix+1) % [llength $fill_msgs]}] } else { error "incomprehensible commandresponsedelay_part response $response" } unset state(ptoid) ic_setresponsetimeout threadio_puts ic $id $state(chan) "$thisline\n" \ commandresponsedelay_ok commandresponsedelay_err \ $delay 0 $final $remainder $f_ix } thread_chainproc ic commandresponsedelay_err \ {delay nopartresp final response f_ix emsg} { ic_unsetcommandresponsetimeout ic_command_err $emsg } thread_chainproc ic commandresponsedelay_ok \ {delay nopartresp final response f_ix} { ic_unsetcommandresponsetimeout ic_commandresponsedelay $delay $nopartresp $final $response $f_ix } thread_chainproc ic commandresponsedelay_after {final response} { unset state(ptoid) ic_commandresponsedelay 0 1 $final $response 0 } thread_chainproc ic tellquit_done {args} { catch { after cancel $state(itoid) } thread_finish ic $id } thread_subproc ic commandfinalresponse {evtype message} { ic_kill_subthreads if {[info exists state(mtachan)]} { threadio_commandresponse ic $id $state(mtachan) quit \ {} mtaquit_done mtaquit_done $evtype $message } else { ic_commandresponse_maybefinal $evtype 1 $message } } thread_subproc ic setresponsetimeout {args} { global command_timeout set state(itoid) [thread_after \ ic $id $command_timeout sendresponse_timedout] } thread_chainproc ic sendresponse_timedout {args} { thread_finish ic $id } thread_chainproc ic mtaquit_done {evtype message args} { fconfigure $state(mtachan) -blocking true catch_close_cleardesc state(mtachan) ic_commandresponse_maybefinal $evtype 1 $message } thread_chainproc ic timedout {} { global canonical_hostname fileevent $state(chan) readable {} ic_commandfinalresponse minor \ "421 $canonical_hostname Timed out waiting for command" } thread_chainproc ic command_err {emsg} { ic_command_err $emsg } thread_subproc ic command_err {emsg} { global annoyance_minor manyset [ic_getsiteannoy $annoyance_minor] cv irritamt set state(smtpreaderr) $emsg logreject notice state dropped {} [string tolower $irritamt] ${cv}ms thread_finish ic $id } thread_subproc ic commandnorhs {rhs} { if {[string length $rhs]} { ic_commandresponse major "501 No parameters allowed" return -code return } } thread_subproc ic check_quitting {} { global canonical_hostname if {![info exists state(quitting)]} { return 0 } ic_commandfinalresponse immed "421 $canonical_hostname Shutting down" return 1 } thread_chainproc ic command_ok {cmd} { global canonical_hostname blacklist_message bland_message global admin_chal_timeout always_blacklist_site wholedata_timeout global adminsecret blacksite_message allow_saucestate mixedkinds_message global blacklist_on_bounces bouncedjunk_message after cancel $state(itoid) unset state(itoid) regexp {^.*} $cmd cmd set state(smtpcmd) $cmd set state(smtpreaderr) {} if {![string length $cmd]} { set state(smtpreaderr) {Empty command} } set state(whyreject) {} if {[ic_check_quitting]} { return } elseif {[eof $state(chan)]} { set state(smtpreaderr) EOF ic_commandfinalresponse major "" return } elseif {![regexp -nocase -- {^([a-z0-9]+)[ \t]*(.*)$} $cmd all verb rhs]} { ic_commandresponse major "500 Syntax error" return } else { set verb [string tolower $verb] switch -exact -- $verb { quit { ic_commandnorhs $rhs ic_commandfinalresponse command \ "221 $canonical_hostname goodbye" } helo { ic_helo helo smtp $rhs } ehlo { ic_helo ehlo esmtp $rhs } mail { if {![info exists state(helostring)]} { ic_commandresponse major "503 need HELO or EHLO before MAIL" } elseif {[info exists state(mf_lp)]} { ic_commandresponse major "503 MAIL already issued" } elseif {[regexp -nocase \ {^from:[ \t]*<(.+)@([^@]+)>[ \t]*(.*)$} \ $rhs all lp dm parms]} { ic_msg_resetvars set state(mf_lp) $lp set state(mf_dm) $dm set state(mf_parms) $parms if {[regexp {^\[.*\]$} $state(mf_dm)]} { ic_mailfrom_fail "550 Domain-literal senders not allowed" } elseif {[catch { address_dequote state(mf_lp) state(mf_dm) } \ emsg]} { ic_mailfrom_fail "501 Syntax error in sender ($emsg)" } else { set str "$state(mf_lp)@$state(mf_dm)" set as [ds_get addr-list $str] set ss [ds_get site-list $state(ra)] if {"$as" == "white" && "$ss" == "white"} { set state(mf_message) "You are on the whitelist" ic_rbl } elseif {"$as" == "black"} { set state(mf_message) "You are on the blacklist" ic_rbl } elseif {"$as" == "unknown"} { set state(avfid) [thread_start avf \ "$state(desc) / verify $str" \ $state(mf_lp) $state(mf_dm)] thread_join ic $id avf $state(avfid) \ mailfrom_avf_ok mailfrom_avf_err } elseif {"$as" == "verified"} { set state(mf_message) "You were verified previously" ic_rbl } else { set state(mf_message) "You are on the greylist" ic_rbl } } } elseif {[regexp -nocase \ {^from:[ \t]*<>[ \t]*(.*)$} \ $rhs all parms]} { ic_msg_resetvars set state(mf_lp) {} set state(mf_dm) {} set state(mf_parms) $parms set ss [ds_get site-list $state(ra)] if {"$ss" == "white"} { set state(mf_message) "Bounce is from whitelisted site" ic_rbl } else { set state(mf_message) "Ready to receive a bounce" ic_rbl } } else { ic_commandresponse major "501 Syntax error in parameter to MAIL" } } vrfy { ic_commandresponse command "252 VRFY not supported by SAUCE." } rcpt { incr state(rcptcounter) if {![info exists state(mf_lp)]} { ic_commandresponse minor "503 need MAIL before RCPT" } elseif {[regexp -nocase -- \ {^to:[ \t]*<(.+)@([^@]+)>[ \t]*$} \ $rhs all lp dm]} { set str "$lp@$dm" if {[catch { address_dequote lp dm } emsg]} { ic_rcptresponse major badsyntax $str \ "501 Syntax error in recipient ($emsg)" } else { set rtcmd "rcpt to:<[lp_quote $lp]@$dm>" manyset [addr_classify $lp $dm state] atype errok if {[info exists state(rcpts_errok_only)]} { set errok \ [expr {$state(rcpts_errok_only) && $errok}] } set state(rcpts_errok_only) $errok regexp {^[0-9a-z]+} $atype atype_summ set kind $atype switch -glob $atype_summ { unchecked { set notafter normal } lax { set notafter {} } nodelay - normal { set kind normal; set notafter {bait unchecked} } bait { set notafter {} } [45]* { ic_rcptresponse major $atype_summ $str $atype return } default { error "internal error - atype $atype" } } set delay_this {} if {"$atype" == "normal" && \ [info exists state(delay_msg)]} { lappend delay_this $state(delay_msg) } if {"[ds_get site-list $state(ra)]" == "black"} { ic_rej_bl "\[$state(ra)\]" site } set mf $state(mf_lp)@$state(mf_dm) if {"[ds_get addr-list $mf]" == "black"} { ic_rej_bl $mf "return path" } set rej_this [concat $state(rej_conn) $state(rej_msg)] set defer_this \ [concat $state(defer_conn) $state(defer_msg)] switch -exact $atype { bait { if {!$blacklist_on_bounces && ![string length $state(mf_dm)]} { ic_commandresponse major \ "550 $bouncedjunk_message" return } lappend state(add_bl) \ "Sent mail to bait address $lp@$dm" if {$always_blacklist_site} ic_blacklist_site ic_rcptresponse command $atype_summ $str \ "250 $bland_message" lappend state(a_kinds) $kind return } normal - nodelay { foreach {varname code badness} { rej_this 550 major defer_this 451 major delay_this 450 rcpt-defer } { set resp [join [set $varname] "\n"] if {[string length $resp]} { smtp_prefix_response $resp $code resp ic_rcptresponse $badness $atype_summ \ $str $resp return } } } unchecked - lax { } default { error "atype ? $atype" } } foreach k $notafter { if {[ic_a_kind $k]} { ic_rcptresponse command $atype_summ $str \ "450 $mixedkinds_message" return } } threadio_commandresponse ic $id $state(mtachan) \ $rtcmd {} mta_rcpt_ok {} $kind $atype_summ $str } } else { ic_commandresponse major \ "501 Syntax error in parameter to RCPT" } } data { ic_commandnorhs $rhs if {![llength $state(a_kinds)]} { ic_commandresponse minor "503 No recipients specified" } else { set state(itoid) [thread_after \ ic $id $wholedata_timeout msg_timedout] threadio_puts ic $id $state(chan) \ "354 Send text\n" askfordata_done command_err } } sauceadmin { if {![string length $rhs]} { set chal [urandom_hex 8] append chal [format %016lx [clock seconds]] set state(lastchal) $chal ic_commandresponse immed "393 $chal" } elseif {![info exists state(lastchal)]} { ic_commandresponse major \ "503 Need SAUCEADMIN on its own first" } else { set waschal $state(lastchal) log notice "$state(desc): ATTEMPTING SWITCH TO ADMIN MODE" if {![regexp \ {^([0-9a-f]{16})([0-9a-f]{16})[ \t]+([0-9a-f]{64})$} \ $rhs all chal wasdate resp]} { ic_commandresponse major "501 \\x{24} \\x{32} please" } elseif {"$chal$wasdate" != "$waschal"} { ic_commandresponse immed "490 challenge overwritten" } elseif {[clock seconds] - [expr "0x$wasdate"] \ > $admin_chal_timeout} { ic_commandresponse immed "491 challenge timed out" } elseif {![string length $adminsecret]} { ic_commandresponse immed "495 admin secret missing" } elseif {"$resp" != \ "[hbcrypto hash sha256 [hbytes concat $waschal $adminsecret]]"} { ic_commandresponse immed "492 incorrect response" unset state(lastchal) } else { log notice "$state(desc): switch to admin mode ok" threadio_puts ic $id $state(chan) "294 yes master\n" \ yesmaster_outdone command_err } } } saucestate { if {$allow_saucestate} { set op "100-$id\n" foreach x [lsort [array names state]] { append op "100-[list $x $state($x)]\n" } append op "100" ic_commandresponse immed $op } else { ic_commandresponse immed "504 SAUCESTATE not available." } } help { ic_commandnorhs $rhs ic_commandresponse command \ {214- 214 QUIT HELP NOOP HELO EHLO MAIL RCPT DATA QUIT RSET VRFY} } noop { ic_commandnorhs $rhs ic_commandresponse command "250 NOOP OK" } rset { ic_commandnorhs $rhs if {[info exists state(mtachan)]} { threadio_commandresponse ic $id $state(mtachan) rset \ {^2[0-9][0-9]} mta_rset_ok {} } else { ic_msg_resetvars ic_commandresponse command "250 OK" } } default { ic_commandresponse major "502 Command unrecognised" } } } } thread_subproc ic helo {helocmd smtpstyle rhs} { global forbid_helo_ipliteral require_reverse_dns canonical_hostname set state(helocmd) $helocmd set state(smtpstyle) $smtpstyle if {[info exists state(helostring)]} { ic_commandresponse major "503 HELO or EHLO already specified" } elseif {[regexp {^\[(\d+\.\d+\.\d+\.\d+)\]$} $rhs all ipliteral]} { if {$forbid_helo_ipliteral} { lappend state(rej_conn) \ "IP literal ($rhs) in HELO forbidden by adminstrator" } ic_find_maildomain $state(rh) $rhs } elseif {![domain_ok $rhs]} { if {[regexp -nocase {[^-_.+@/<>0-9a-z]} $rhs]} { ic_commandresponse major "501 Invalid characters in HELO domain" } else { lappend state(rej_conn) "Syntax error in HELO domain `$rhs'" ic_find_maildomain $state(rh) $rhs } } else { if {"[string tolower $rhs]" == "[string tolower $state(rh)]"} { ic_find_maildomain $rhs $rhs } elseif {"$state(ra)" == "127.0.0.1"} { ic_set_maildomain $canonical_hostname $rhs } elseif {"[ds_get site-list $state(ra)]" == "white"} { ic_set_maildomain "\[$state(ra)\]" $rhs } else { set state(dnsid) [thread_start dns "$state(desc) / HELO lookup" $rhs A 0] thread_join ic $id dns $state(dnsid) helodns_ok helodns_err $rhs } } } thread_chainproc ic helodns_ok {hs answers emsgstr how} { global check_helo_name require_callingmaildomain_dnsok unset state(dnsid) if {[llength $answers]} { if {[lsearch -exact $answers $state(ra)] != -1} { ic_find_maildomain $hs $hs } else { if {$check_helo_name} { lappend state(rej_conn) \ "HELO name $hs has no address matching $state(ra)" } ic_find_maildomain $state(rh) $hs } } else { if {"$how" == "MISCONFIG" && $require_callingmaildomain_dnsok} { lappend state(rej_conn) \ "HELO name lookup revealed misconfiguration: $emsgstr" } elseif {$check_helo_name} { lappend state(rej_conn) "HELO name incorrect: $emsgstr" } ic_find_maildomain $state(rh) $hs } } thread_chainproc ic helodns_err {hs emsg} { unset state(dnsid) lappend state(defer_conn) "HELO name lookup failed: [singleline $emsg]" ic_find_maildomain $state(rh) $hs } thread_subproc ic find_maildomain {chstart hs} { global require_callingmaildomain_name require_reverse_dns if {![string match {\[*\]} $chstart]} { ic_findmore_maildomain $chstart $chstart $hs } else { if {$require_callingmaildomain_name && !$require_reverse_dns} { lappend state(rej_conn) \ "Cannot find $state(ra) host name via reverse DNS or HELO" } ic_set_maildomain $chstart $hs } } thread_subproc ic findmore_maildomain {chstart chnow hs} { if {[llength [split $chnow .]] == 1} { ic_set_maildomain $chstart $hs } else { set state(dnsid) [thread_start dns "$state(desc) / maildomain lookup" \ $chnow MX 1] thread_join ic $id dns $state(dnsid) fch_ok fch_err $chstart $chnow $hs } } thread_chainproc ic fch_ok {chstart chnow hs answers emsgstr how} { global require_callingmaildomain_dnsok unset state(dnsid) if {[llength $answers]} { ic_set_maildomain $chnow $hs } else { if {"$how" == "MISCONFIG" && $require_callingmaildomain_dnsok} { lappend state(rej_conn) "While finding mail domain: $emsgstr" } regsub {^[^.]+\.} $chnow {} chnow ic_findmore_maildomain $chstart $chnow $hs } } thread_chainproc ic fch_err {chstart chnow hs emsg} { global require_callingmaildomain_dnsok unset state(dnsid) if {$require_callingmaildomain_dnsok} { lappend state(defer_conn) \ "Problem finding mail domain: [singleline $emsg]" } ic_set_maildomain $chstart $hs } thread_subproc ic set_maildomain {ch hs} { set state(cmdomain) $ch set state(helostring) $hs ic_mtachan_open } thread_subproc ic mtachan_open {} { set lcmd [list open |[list sendmail -bs -oem \ -oMa $state(ra) -oMr $state(smtpstyle)-sauce \ -oMs $state(rh) -oMt $state(ident)] r+] debug 2 "running sendmail: $lcmd" set state(mtachan) [eval $lcmd] fconfigure $state(mtachan) -blocking false -translation {binary crlf} chanset_desc $state(mtachan) "$state(desc) / MTA" threadio_commandresponse ic $id $state(mtachan) {} {} mta_greeting_ok {} } thread_chainproc ic mta_greeting_ok {data} { if {![regexp {^220} $data]} { ic_mta_greethelo_err $data return } threadio_commandresponse ic $id $state(mtachan) \ "$state(helocmd) $state(helostring)" {} mta_helo_ok {} } thread_subproc ic mta_greethelo_err {emsg} { global canonical_hostname regsub -nocase {^[0-9]* ?[-+.:0-9a-z]* *} $emsg {} emsg ic_commandfinalresponse major "421 $canonical_hostname MTA $emsg" } thread_chainproc ic mta_helo_ok {data} { global canonical_hostname if {![regexp {^2[0-9][0-9]} $data]} { ic_mta_greethelo_err $data return } set str "$canonical_hostname hello $state(ident)@$state(rh)" append str " (postmaster@$state(cmdomain)?)" set exts {} set silently [info exists state(heloexts)] if {"$state(helocmd)" == "helo"} { } elseif {"$state(helocmd)" == "ehlo"} { foreach l [lrange [split $data "\n"] 1 end] { if {[regexp -nocase {^250[- ]([-a-z0-9]+)(.*)$} $l \ all keyword params]} { set params [string trim $params] if {[string length $params]} { set params " $params" } switch -exact -- [string tolower $keyword] { 8bitmime - size { lappend exts "[string toupper $keyword]$params" } } } } manyset [ic_getsiteannoy 0] cv irritamttxt if {$cv <= 0 || \ [info exists state(heloexts)] && \ [lsearch $state(heloexts) PIPELINING]>=0} { lappend exts PIPELINING } if {[info exists state(heloexts)]} { foreach item $state(heloexts) { if {[lsearch -exact $exts $item]==-1} { # Oh, we advertised something before but not # the MTA isn't advertising it any more ! Doom. ic_commandfinalresponse minor \ "421 $canonical_hostname Internal error (EHLO extension lost: $item)" return } } } else { set state(heloexts) $exts } } else { error "internal error - ugh? $helocmd" } if {!$silently} { # mtachan_open was called as a result of HELO or EHLO command set op {} for {set i -1} {$i < [llength $exts]} {incr i} { set notlast [expr {$i+1 < [llength $exts]}] append op 250 if {$notlast} { append op - } else { append op " " } if {$i>=0} { append op [lindex $exts $i] } else { append op $str } if {$notlast} { append op "\n" } } ic_commandresponse nopartresp $op } else { # mtachan_open was called as a result of another command dropping # the MTA chan and needing to return to post-HELO state ic_setcommandtimeout threadio_gets ic $id $state(chan) command_ok command_err } } thread_subproc ic mailfrom_fail {message} { unset state(mf_lp) unset state(mf_dm) unset state(mf_parms) catch { unset state(mf_message) } catch { unset state(minsiteage) unset state(minaddrage) } ic_commandresponse major $message } thread_chainproc ic mailfrom_avf_ok {ok message} { unset state(avfid) if {!$ok} { set sl [singleline "invalid MAIL-FROM: $message"] ic_rej $sl set message "Warning! Rejection likely: $sl" } set state(mf_message) $message ic_rbl } thread_chainproc ic mailfrom_avf_err {message} { unset state(avfid) set sl [singleline "problematic MAIL-FROM: $message"] lappend state(defer_msg) $sl set state(mf_message) "Warning! Deferral likely: $sl" ic_rbl } thread_subproc ic rbl {} { global rbls new_addr_defer new_site_defer new_addr_message new_site_message set state(minaddrage) 0 set state(minsiteage) 0 ic_rbl_minage addr $state(mf_lp)@$state(mf_dm) $new_addr_defer $new_addr_message ic_rbl_minage site $state(ra) $new_site_defer $new_site_message set tolookup {} foreach dq [split $state(ra) .] { set tolookup $dq.$tolookup } foreach rbl $rbls { manyset $rbl dm maa msa rblmsg regsub -all {%d} $rblmsg $dm rblmsg set thread [thread_start dns "$state(desc) / rbl $dm" $tolookup$dm TXT 1] lappend state(rblids) $thread thread_join ic $id dns $thread rbl_done rbl_err \ $thread $dm $maa $msa $rblmsg } ic_rbl_checkdone } thread_chainproc ic rbl_done {thread dm maa msa rblmsg answers emsgstr etype} { ic_rbl_rmthread $thread switch -exact -- $etype { NXDOMAIN - NOTYPE { } MISCONFIG { log notice "RBL misconfigured! $emsgstr" } OK { if {![llength $answers]} { error "no answers, no error" } lappend state(rbl_hits) $dm set l {} foreach a $answers { regsub {^\"} $a {} a regsub {\"$} $a {} a set a [proto_quote $a] lappend l $a } regsub -all {%m} $rblmsg [join $l ", "] rblmsg regsub -all {%p} $rblmsg {%} rblmsg if {![string length $maa]} { lappend state(rej_conn) [singleline $rblmsg] } else { ic_rbl_minage addr $state(mf_lp)@$state(mf_dm) $maa $rblmsg ic_rbl_minage site $state(ra) $msa $rblmsg } } default { error "[list $etype $answers $emsgstr] ?" } } ic_rbl_checkdone } thread_chainproc ic rbl_err {thread dm maa msa rblmsg emsg} { ic_rbl_rmthread $thread ic_rbl_checkdone } thread_subproc ic rbl_rmthread {thread} { set ntl {} foreach t $state(rblids) { if {"$t" != "$thread"} { lappend ntl $t } } set state(rblids) $ntl } thread_subproc ic rbl_minage {what key newminage msg} { upvar #0 remember_${what}_defer remember_defer debug 2 rbl_minage $what $key $newminage $msg if {!$newminage} return if {"$key" == "@"} return set whatstate [ds_get $what-list $key] if {"$whatstate" == "white" || "$whatstate" == "whitesoon"} return if {$state(min${what}age) >= $newminage} return set state(min${what}age $newminage set now [clock seconds] set firstcontact [ds_get $what-seen $key] if {"$firstcontact" == "unknown"} { set firstcontact $now ds_set $what-seen $key $now $remember_defer debug 2 rbl_minage ... firstcontact $now } if {$now < $firstcontact+$newminage} { set state(delay_msg) $msg debug 2 rbl_minage ... defer $now $firstcontact+$newminage } } thread_subproc ic rbl_checkdone {} { if {[llength $state(rblids)]} return ic_mailfrom_ok } thread_subproc ic mailfrom_ok {} { global max_smtpparms_size if {[string length $state(mf_parms)] > $max_smtpparms_size} { ic_mailfrom_fail "503 MAIL FROM parameter string too long" } else { set addr "[lp_quote $state(mf_lp)]@$state(mf_dm)" if {"$addr" == "@"} { set addr {} } threadio_commandresponse ic $id $state(mtachan) \ "mail from:<$addr> $state(mf_parms)" {} mta_mailfrom_ok {} } } thread_chainproc ic mta_mailfrom_ok {data} { if {[regexp {^2[0-9][0-9]} $data]} { smtp_prefix_response $state(mf_message) 250 message ic_commandresponse command $message unset state(mf_message) unset state(mf_parms) catch { unset state(minsiteage) unset state(minaddrage) } } else { ic_mailfrom_fail $data } } thread_subproc ic rcptresponse {evtype atype_summ rcpt response} { regexp {^[0-9][0-9][0-9]} $response code lappend state(att_rcpts) [list $atype_summ $rcpt $code] ic_commandresponse $evtype $response } thread_chainproc ic mta_rcpt_ok {kind atype_summ rcpt data} { if {[regexp {^2[0-9][0-9]} $data]} { lappend state(a_kinds) $kind set evtype command } else { set evtype major } ic_rcptresponse $evtype $atype_summ $rcpt $data } thread_chainproc ic mta_rset_ok {data} { catch { unset state(mf_lp) } ic_commandresponse command "250 OK" } work/stall.tcl0000664000000000000000000000504115116102070010544 0ustar ########### stall.tcl # # Pure-teergrube server (over-aggressive callers are diverted here) # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: stall.tcl,v 1.1.4.1 2008/03/08 15:42:34 ian Exp $ ########## stalling threads # thread_start $chan $desc # # errors/results ignored # # state variables: # # Always set: # chan incoming SMTP connection # counter no. of messages we have sent # timeout id of timeout after (or unset) thread_typedefine stall {ra chan explain} { global nstalls stalls_max addrconcurr set state(chan) $chan set state(counter) 0 set stallscounts "$addrconcurr(nstalls:$ra)/$nstalls/$stalls_max" log reject "$ra stalling ($stallscounts) $explain" fconfigure $state(chan) -buffering none threadio_gets stall $id $state(chan) finish finish stall_pause {} $explain } { thread_finish stall $id } { catch { after cancel $state(timeout) } catch { fileevent $state(chan) readable {} } catch { fileevent $state(chan) writable {} } } thread_subproc stall pause {newline message} { global stall_interval set state(timeout) [thread_after stall $id $stall_interval \ write $newline $message] } thread_chainproc stall write {newline message} { global stall_count command_timeout incr state(counter) set resp $newline append resp 421 if {$state(counter) < $stall_count} { append resp "-$message" set onok written } else { append resp " $message\n" set onok finish } set state(timeout) [thread_after \ stall $id $command_timeout stall finish] threadio_puts stall $id $state(chan) $resp $onok finish } thread_chainproc stall written {} { after cancel $state(timeout) stall_pause "\n" $state(counter) } thread_chainproc stall finish {args} { thread_finish stall $id } work/subst.tcl0000664000000000000000000000413015116102070010563 0ustar ########### subst.tcl # Run with two args: settingsfile, filename.ext # Then copies input file . to output file , # making substitutions as specified in # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: subst.tcl,v 1.8 2003/06/15 15:46:40 ian Exp $ source instlib.tcl if {[llength $argv] != 2} { error "need exactly two args" } source [lindex $argv 0] set infilename [lindex $argv 1] regexp {^(.+)\.([^.]+)$} $infilename dummy filename ext switch -exact $ext { tcl { set hashpling 1 set removeset 1 } in { set hashpling 0 set removeset 0 } default { error $ext } } set in [open $infilename r] set mode 0666 if {[file executable $infilename]} { set mode 0777 } set out [open $filename.new w $mode] set line1 1 while {[gets $in line] >= 0} { if {$line1 && $hashpling && [regexp {^\#\!.*tclsh} $line]} { set line "#! $_tclsh" } elseif {$removeset && [regexp {^set[ \t]+\@\@\@[a-z_]+\??\@\@\@[ \t]} $line]} { continue } else { while {[regexp {^(.*)\$\{\@\@\@([a-z_]+)(\??)\@\@\@\}(.*)$} \ $line all lhs vn allow0 rhs]} { set v [set $vn$allow0] set v [string_quote $v [string length $allow0]] set line $lhs$v$rhs } regsub -all {\$\{\@\@\@\}} $line @@@ line } puts $out $line set line1 0 } close $in close $out file rename -force $filename.new $filename work/t.tcl0000664000000000000000000000060215116102070007666 0ustar # LD_LIBRARY_PATH=../chiark-tcl/adns:../chiark-tcl/base valgrind --db-attach=yes tclsh t.tcl load chiark_tcl_adns-1.so proc pproc {x} { proc $x {args} "puts \"$x \$args\"" } pproc pinfo pproc yes pproc no pproc maybe set adns [adns new-resolver -errcallback pinfo] set q [eval \ [list adns asynch yes no maybe 14 cname chiark.greenend.org.uk] \ [list -resolver $adns]] vwait spong work/testfiles0000664000000000000000000000577115116102070010660 0ustar mail from: rset mail from: rset mail from: rset mail from: rset mail from: helo davenant.relativity.greenend.org.uk mail from: rcpt to: data Subject: normal test many Message-ID: body . helo davenant.relativity.greenend.org.uk mail from: rcpt to: data Subject: non-blacklisted spammer to bait From: real-testac@davenant.greenend.org.uk Message-ID: body . helo davenant.relativity.greenend.org.uk mail from: rcpt to: data Subject: non-blacklisted spammer to normal From: real-testac@davenant.greenend.org.uk Message-ID: body . helo davenant.relativity.greenend.org.uk mail from: rcpt to: data Subject: normal to discard-all Message-ID: body . rset helo davenant.relativity.greenend.org.uk mail from: rcpt to: data Subject: normal from nonspammer From: broken to discard-all Message-ID: From: test002x@davenant.greenend.org.uk body . rset mail from: helo davenant.relativity.greenend.org.uk mail from: rcpt to: data Subject: normal from nonspammer to discard-all Message-ID: From: test002@davenant.greenend.org.uk, test003@davenant.greenend.org.uk, test004@davenant.greenend.org.uk, test005@davenant.greenend.org.uk, test006@davenant.greenend.org.uk, test007@davenant.greenend.org.uk, test008@davenant.greenend.org.uk body . ehlo davenant.relativity.greenend.org.uk mail from:<> rcpt to: data Message-ID: From: test005x@davenant.greenend.org.uk Subject: bounce virus to postmaster body start *TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA* . ehlo davenant.relativity.greenend.org.uk mail from:<> rcpt to: data Message-ID: From: test005x@davenant.greenend.org.uk Subject: bounce outhouse to postmaster Resent-To: Resent-Message-ID: X-Mailer: Microsoft Outlook Express 6.00.2800.1807 body . work/thread.tcl0000664000000000000000000002654015116102070010703 0ustar ########## thread.tcl # `Thread'-handling functions # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: thread.tcl,v 1.24 2006/04/02 18:22:49 ian Exp $ proc thrdbg_threads {type} { foreach x [lsort [info globals]] { if {[string match $type/* $x]} { puts $x } } } proc thrdb_state {type/id} { upvar #0 [set type/id] state foreach n [lsort [array names state]] { puts [list set $n $state($n)] } } proc thread_typedefine {type formarglist startbody shutdownbody cleanbody} { upvar #0 $type/nid nid if {![info exists nid]} { set nid 0 } if {"$shutdownbody" == "ERROR-ON-SHUTDOWN"} { set shutdownbody "\n thread_error $type \$id {shut down} {}\n" } elseif {"$shutdownbody" == "NO-CLEAN-SHUTDOWN"} { set shutdownbody "\n global threads\n unset threads(\[list $type \$id\])\n" } proc $type/start [concat id $formarglist] " upvar #0 $type/\$id state\n$startbody" proc $type/shutdown {id} " upvar #0 $type/\$id state\n$shutdownbody" proc $type/clean {id} " upvar #0 $type/\$id state\n$cleanbody" } proc thread_chainproc {type name formarglist body} { proc $type//$name [concat id $formarglist] " upvar #0 $type/\$id state\n$body" } proc thread_subproc {type name formarglist body} { proc "${type}_$name" $formarglist " upvar id id\n upvar state state\n$body" } proc thread_start {type desc args} { global errorInfo threads upvar #0 $type/nid id incr id upvar #0 $type/$id state debug0 2 [list $type $id start] $args if {[catch { if {[info exists state]} { error "$type/$id already exists" } set state(desc) $desc set threads([list $type $id]) 1 eval [list $type/start $id] $args } emsg]} { log error "Tcl error (startup) $type $args:\n $errorInfo" set state(r_emsg) $emsg $type/clean $id } return $id } proc thread_shuttingdown {} { global terminating return [info exists terminating] } proc thread__shutdowncheck {} { global terminating threads debug0 2 shutdowncheck [thread_shuttingdown] [array names threads] if {![thread_shuttingdown]} return if {[array size threads]} return eval $terminating } proc thread_sysshutdown {script} { global terminating threads errorInfo set terminating $script thread__shutdowncheck foreach ti [array names threads] { manyset $ti type id if {[catch { eval $type/shutdown $id } emsg]} { thread_error $type $id $emsg \ "Tcl error (shutting down) $type $id:\n $errorInfo" } } thread__shutdowncheck } proc thread_forceshutdown {} { global threads foreach ti [array names threads] { manyset $ti type id upvar #0 $type/$id state if {[info exists state(desc)]} { set desc $state(desc) } else { set desc {} } debug0 1 "thread still running: $type/$id $desc" } log notice "shutdown tidy timed out, quitting now" exit 1 } proc thread__cleanup {type id} { global threads debug0 2 cleanup $type $id catch { unset threads([list $type $id]) } $type/clean $id thread__shutdowncheck } proc thread__docancel {type id} { global threads upvar #0 $type/$id state if {![info exists state(r_emsg)] && ![info exists state(r_result)]} { thread__cleanup $type $id } unset state } proc thread_cancel {type id} { debug0 2 [list $type $id cancel] thread__docancel $type $id } proc thread_chain {type func args} { upvar id id thread__eval $type $id $func $args {} } proc thread_crosscall {type id func args} { thread__eval $type $id $func $args {} } proc thread__eval {type id func argsl1 argsl2} { global errorInfo if {![string length $type]} { eval $func $argsl1 $argsl2 } elseif {![string length $func]} { set emsg [lindex $argsl2 0] debug0 2 [list propagated-error $type $id $emsg $argsl1 $argsl2] thread_error $type $id $emsg {} } elseif {[catch { eval $type//$func $id $argsl1 $argsl2 } emsg]} { thread_error $type $id $emsg \ "Tcl error $type $id $func $argsl1 $argsl2:\n $errorInfo" } else { return $emsg } return {} } proc thread__checkdone {} { upvar type type upvar state state upvar id id if {[info exists state(r_emsg)] && [info exists state(ca_onerrf)]} { set emsg $state(r_emsg) set ca_type $state(ca_type) set ca_id $state(ca_id) set ca_onerrf $state(ca_onerrf) set ca_xargs $state(ca_xargs) debug0 2 [list $type $id error $emsg] thread__docancel $type $id thread__eval $ca_type $ca_id $ca_onerrf $ca_xargs [list $emsg] } elseif {[info exists state(r_result)] && [info exists state(ca_onokf)]} { set values $state(r_result) set ca_type $state(ca_type) set ca_id $state(ca_id) set ca_onokf $state(ca_onokf) set ca_xargs $state(ca_xargs) debug0 2 [list $type $id finish] $values thread__docancel $type $id thread__eval $ca_type $ca_id $ca_onokf $ca_xargs $values } } proc thread_error {type id emsg loginfo} { global threads upvar #0 $type/$id state if {[string length $loginfo]} { log error $loginfo } set state(r_emsg) $emsg thread__cleanup $type $id thread__checkdone } proc thread_finish {type id args} { global threads upvar #0 $type/$id state set state(r_result) $args thread__cleanup $type $id thread__checkdone } proc thread_join {mytype myid type id ca_onokf ca_onerrf args} { upvar #0 $type/$id state set state(ca_type) $mytype set state(ca_id) $myid set state(ca_onokf) $ca_onokf set state(ca_onerrf) $ca_onerrf set state(ca_xargs) $args thread__checkdone } proc thread_fileevent {type id chan what func args} { fileevent $chan $what [list thread__eval $type $id $func $args {}] } proc thread_after {type id timeout func args} { return [after $timeout [list thread__eval $type $id $func $args {}]] } proc bgerror {msg} { global errorCode errorInfo log error "thread: untrapped error: $msg ($errorCode $errorInfo)" } ########## threadio functions proc chan_debug {lev desc dirn str} { foreach le [split $str "\n"] { if {[string length $le]} { debug0 $lev "$desc $dirn $le" } } } proc threadio__edesc {emsg} { global errorCode set ecode $errorCode switch -exact [lindex $ecode 0] { POSIX { return [lindex $ecode 2] } CHILDKILLED { return "subprocess failed: [lindex $ecode 3]" } CHILDSTATUS { return "subprocess failed with exit status [lindex $ecode 2]" } default { return "$ecode -- $emsg" } } } proc threadio_gets {type id chan onokf onerrf args} { fileevent $chan readable \ [list threadio__gets_ready $type $id $chan $onokf $onerrf $args] } proc threadio__gets_ready {type id chan onokf onerrf argsl} { global chan_desc manyset $chan_desc($chan) cd cdhi cdho if {[catch { gets $chan str } emsg]} { set edesc [threadio__edesc $emsg] fileevent $chan readable {} debug0 1 "$cd ** reading: $edesc $emsg" thread__eval $type $id $onerrf $argsl [list $edesc] } elseif {[fblocked $chan]} { return } elseif {[eof $chan]} { fileevent $chan readable {} debug0 1 "$cd <<\$\$" thread__eval $type $id $onokf $argsl {{}} } else { regsub {\r$} $str {} str fileevent $chan readable {} chan_debug $cdhi $cd {<<} $str thread__eval $type $id $onokf $argsl [list $str] } } proc threadio__puts_debug {chan data} { global chan_desc manyset $chan_desc($chan) cd cdhi cdho chan_debug $cdho $cd {>>} $data } proc threadio__puts_puts {chan data} { puts -nonewline $chan $data } proc threadio_puts_throw {chan data} { threadio__puts_debug $chan $data threadio__puts_puts $chan $data } proc threadio_puts {type id chan data onokf onerrf args} { threadio__puts_debug $chan $data fileevent $chan writable [list threadio__puts_ready $type $id \ $chan $data $onokf $onerrf $args] } proc threadio__puts_ready {type id chan data onokf onerrf argsl} { global chan_desc manyset $chan_desc($chan) cd cdhi cdho if {[catch { threadio__puts_puts $chan $data flush $chan } emsg]} { set edesc [threadio__edesc $emsg] fileevent $chan writable {} debug0 1 "$cd ** writing: $edesc $emsg" thread__eval $type $id $onerrf $argsl [list $edesc] } elseif {[fblocked $chan]} { return } else { fileevent $chan writable {} thread__eval $type $id $onokf $argsl {} } } proc threadio__putsgets_puts_ok {type id chan onokf onerrf argsl} { eval [list threadio_gets $type $id $chan $onokf $onerrf] $argsl } proc threadio__putsgets_puts_err {type id chan onokf onerrf argsl emsg} { thread__eval $type $id $onerrf $argsl [list $emsg] } proc threadio_putsgets {type id chan data onokf onerrf args} { threadio_puts {} {} $chan $data \ threadio__putsgets_puts_ok threadio__putsgets_puts_err \ $type $id $chan $onokf $onerrf $args } proc threadio__commandresponse_line_ok \ {type id chan re onokf onerrf sofar argsl what data} { regexp {^.*} $data data if {[eof $chan]} { thread__eval $type $id $onerrf $argsl [list "${what}connection dropped"] } elseif {[regexp {^[0-9][0-9][0-9]-} $data]} { append sofar $data "\n" threadio_gets {} {} $chan \ threadio__commandresponse_line_ok threadio__commandresponse_line_err \ $type $id $chan $re $onokf $onerrf $sofar $argsl $what } elseif {[regexp {^[0-9][0-9][0-9]} $data]} { append sofar $data if {[regexp -- $re $data]} { thread__eval $type $id $onokf $argsl [list $sofar] } else { thread__eval $type $id $onerrf $argsl [list "$what$sofar"] } } else { thread__eval $type $id $onerrf $argsl [list "${what}invalid $data"] } } proc threadio__commandresponse_line_err \ {type id chan re onokf onerrf sofar argsl what emsg} { thread__eval $type $id $onerrf $argsl [list $emsg] } proc threadio_commandresponse {type id chan cmd re onokf onerrf args} { if {[string length $cmd]} { append cmd "\n" regexp {^[^ \t\n]*} $cmd what set what "[string trim [string toupper $what]] => " } else { set what "" } threadio_putsgets {} {} $chan $cmd \ threadio__commandresponse_line_ok threadio__commandresponse_line_err \ $type $id $chan $re $onokf $onerrf {} $args $what } proc chanset_desc {chan msg} { global chan_desc set chan_desc($chan) [list $msg 1 1] } proc chanset_hide {chan in out} { upvar #0 chan_desc($chan) cde set cde [lreplace $cde 1 2 $in $out] } proc catch_close_cleardesc {chanvar} { # closes and cleans up the channel whose name is stored # in the variable named by chanvar. Idempotent (unsets # the variable). global chan_desc catch { upvar 1 $chanvar chan set ochan $chan unset chan catch { fileevent $ochan writable {} } catch { fileevent $ochan readable {} } catch { debug0 1 "[lindex $chan_desc($ochan) 0] >>\$\$" } catch { close $ochan } catch { unset chan_desc($ochan) } } } work/x.gdb0000664000000000000000000000020315116102070007641 0ustar set env LD_LIBRARY_PATH ../chiark-tcl/adns:../chiark-tcl/base set args t.tcl file /usr/bin/tclsh run break cht_ret_iddata signal 0 work/yesmaster.tcl0000664000000000000000000001041115116102070011436 0ustar ########### msgdata.tcl # Routines (part of main program) for dealing with SAUCEADMIN. # # This file is part of SAUCE, a very picky anti-spam receiver-SMTP. # SAUCE is Copyright (C) 1997-2003 Ian Jackson. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # $Id: yesmaster.tcl,v 1.16 2003/06/15 15:46:40 ian Exp $ # state variables used during tcl commands processing: # sofar partially received command set yesmaster_shutdowns {} thread_chainproc ic yesmaster_outdone {} { ic_yesmaster_startcmd } thread_subproc ic yesmaster_startcmd {} { set state(sofar) {} threadio_putsgets ic $id $state(chan) "% " yesmaster_gotdata yesmaster_err } thread_chainproc ic yesmaster_gotdata {data} { global errorInfo yesmaster_shutdowns threads if {![string length $data] && [eof $state(chan)]} { thread_finish ic $id return } append state(sofar) $data if {"$state(sofar)" == ";"} { set state(sofar) {} threadio_putsgets ic $id $state(chan) "\nEOP\n" yesmaster_gotdata yestmaster_err return } if {"[string trim $state(sofar)]" == "shutdown"} { unset threads([list ic $id]) shutdown } elseif {[info complete $state(sofar)]} { set code [catch [list uplevel #0 $state(sofar)] result] if {$code} { set output "** $errorInfo\n" } elseif {[string length $result]} { set output "=> $result\n" } else { set output {} } threadio_puts ic $id $state(chan) $output yesmaster_outdone yesmaster_err } else { threadio_gets ic $id $state(chan) yesmaster_gotdata yesmaster_err } } thread_chainproc ic yesmaster_err {emsg} { log notice "$state(desc): error during admin: $emsg" thread_finish ic $id } ########## adminsecret thread # # thread_start adminsecret $desc # # never returns # state variables: # toid timeout id thread_typedefine adminsecret {} { adminsecret_refresh } NO-CLEAN-SHUTDOWN { global adminsecret set adminsecret {} catch { after cancel $state(toid) } } thread_chainproc adminsecret timeout {} { adminsecret_refresh } thread_subproc adminsecret refresh {} { global adminsecret admin_secret_length admin_secret_refresh var_dir set adminsecret {} set chan {} if {[catch { set new [urandom_hex $admin_secret_length] if {[file exists $var_dir/adminsecret] && [file size $var_dir/adminsecret] <= $admin_secret_length * 2} { set mode {WRONLY CREAT} } else { set mode w } set chan [open $var_dir/adminsecret $mode 0600] puts -nonewline $chan $new close $chan unset chan set adminsecret $new log notice "new admin secret set" } emsg]} { log error "unable to make new admin secret: $emsg" } thread_after adminsecret $id $admin_secret_refresh timeout } ########## helper and command functions for sauceadmin # proc show {args} { return [join $args] } proc help {} { show {Some useful commands: readconfig reread config files reopenlogs reopen log files show like puts, but goes where you want it exit stop SAUCE immediately set debug_level set debugging level set reconfigure - but be careful, no checking ! userblacklist addr|site } } proc ? {} { help } proc userblacklist {type newst entry force why} { set st [ds_get $type-list $entry] if {"$newst" == "unknown"} { set newst whitesoon set to -1 } else { upvar #0 ${type}_blacklist_timeout to } switch -exact -- $st { whitesoon - black - verified { } default { if {!$force} { return "$type state is $st: $entry" } } } setstate $type $entry $why $newst $to return "$type ${newst}listed: $entry" }