/pliant/protocol/smtp/server.pli
1	abstract
2	[This is Pliant SMTP server implementation (RFC 821)]
3
4	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
5	#
6	# This program is free software; you can redistribute it and/or
7	# modify it under the terms of the GNU General Public License version 2
8	# as published by the Free Software Foundation.
9	#
10	# This program is distributed in the hope that it will be useful,
11	# but WITHOUT ANY WARRANTY; without even the implied warranty of
12	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13	# GNU General Public License for more details.
14	#
15	# You should have received a copy of the GNU General Public License
16	# version 2 along with this program; if not, write to the Free Software
17	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
18
19	module "/pliant/install/minimal.pli"
20	module "/pliant/language/compiler.pli"
21	module "/pliant/language/context.pli"
22	module "/pliant/language/stream.pli"
23	module "/pliant/admin/file.pli"
24	module "/pliant/language/os/socket.pli"
25	module "/pliant/protocol/common/tcp_server.pli"
26	module "/pliant/protocol/common/misc.pli"
27	module "/pliant/protocol/dns/client.pli"
28	module "/pliant/fullpliant/this_computer.pli"
29	module "/pliant/util/encoding/html.pli"
30	module "/pliant/util/encoding/date.pli"
31	module "meta.pli"
32	module "mail.pli"
33	module "forward.pli"
34	module "client.pli"
35	module "/pliant/language/schedule/resourcesem.pli"
36
37	constant pattern_matching true
38	constant use_spam_filter true
39
40	public
41	gvar Float smtp_auto_answer_timeout := 120
42
43	if use_spam_filter
44	module "spam.pli"
45
46
47	(gvar TraceSlot smtp_trace) configure "SMTP server"
48
49	function real_email full -> real
50	arg Str full real
51	if (full parse any "<" any:real ">" any)
52	void
53	eif (full parse any:real "(" any ")")
54	void
55	else
56	full parse any:real
57
58	function ac_real_email full -> real
59	arg Str full real
60	real := lower real_email:full
61
62
63
64
65
66	public
67	type SmtpServer
68	tcp_server_fields "SMTP" 25
69	TcpServer maybe SmtpServer
70
71
72	type SmtpFile
73	field CBool forward <- false
74	field CBool push <- false
75	field List:Str to
76
77	type SmtpSession
78	field Str local_name
79	field Str remote_name
80	field Str remote_ip
81	field CBool remote_magic <- false
82	field Str id
83	field CBool welcome <- false
84	field CBool accepted <- false
85	field CBool rejected <- false
86	field CBool magic <- false
87	field Str from  ; field Str outmail
88	field List:Str to
89	field (Dictionary Str SmtpFile) files
90	field (Dictionary Str CBool) to_confirmed
91	field CBool check_ip check_from check_to <- false
92	field TraceSession log
93	if use_spam_filter
94	field List:Str spam_filters
95	field Int spam_level <- -1
96	field Str auto_from auto_to auto_subject auto_messageid auto_answer
97
98
99	method session reset
100	arg_rw SmtpSession session
101	session id := generate_id
102	session rejected := false
103	session accepted := false
104	session magic := session remote_magic
105	session from := "" ; session outmail := ""
106	session to := var List:Str empty_to
107	session files := var (Dictionary Str SmtpFile) empty_files
108	session check_ip := false
109	session check_from := false
110	session check_to := false
111	session auto_from := "" ; session auto_to := "" ; session auto_subject := "" ; session auto_messageid := "" ; session auto_answer := ""
112	if use_spam_filter
113	session spam_level := -1
114
115
116	method session add_file filename target -> file
117	arg_rw SmtpSession session ; arg Str filename target ; arg_RW SmtpFile file
118	file :> session:files first filename
119	if not exists:file
120	session:files insert filename (var SmtpFile empty_list)
121	file :> session:files filename
122	if target<>""
123	if not exists:(session:to_confirmed first ac_real_email:target)
124	session:to_confirmed insert ac_real_email:target (exists mailbox:(real_email target):accept_from:(real_email session:from))
125
126	method session check_from_to b
127	arg_rw SmtpSession session ; arg Data:MailBox b
128	if session:outmail<>""
129	session check_from := true
130	session check_to := true
131	if b:check_ip
132	session check_ip := true
133	if b:check_from
134	session check_from := true
135	if b:check_to
136	session check_to := true
137
138	method session receive_mail_content s filename -> a
139	arg_rw SmtpSession session ; arg_rw Stream s ; arg Str filename a
140	a := ""
141	(var Stream mail) open filename out+mkdir+safe
142	mail writeline "Received: from "+session:remote_name+"("+session:remote_ip+") by "+session:local_name+"; "+rfc1123_date:datetime
143	var CBool from_provided := false
144	var Int loop := 0
145	var Str suspicious := "" ; var List:Str comments
146	var CBool empty_line := false
147	if session:check_ip and session:outmail="" and (dns_query session:remote_name 1)<>session:remote_ip
148	suspicious += " server" ; comments += "Sending server is suspicious."
149	part receive_header
150	while not s:atend and { var Str l := s readline ; l<>"." }
151	if l=""
152	empty_line := true
153	leave receive_header
154	while not s:atend and { var Char ch := s:stream_read_cur map Char ; ch=" " or ch="[tab]" }
155	l += s readline
156	if (l parse acpattern:"From:" any:(var Str from))
157	if ac_real_email:from<>(ac_real_email session:from) and session:check_from
158	suspicious += " from" ; comments += "Sender configuration is suspicious." # The '"+l+"' in the mail header does not match the 'MAIL FORM: "+session:from+"' provided as an SMTP instruction.
159	from_provided := true
160	var Str from2 := ac_real_email from
161	if exists:(mail_database:data:magic_from from2)
162	session magic := true
163	eif exists:(mail_database:data:black_from from2)
164	session spam_level := 1 ; comments += "Sender mailbox is blacklisted."
165	from2 := from2 (from2 search "@" from2:len)+1 from2:len
166	if exists:(mail_database:data:magic_from from2)
167	session magic := true
168	eif exists:(mail_database:data:black_from from2)
169	session spam_level := 1 ; comments += "Sender domain is blacklisted."
170	if session:check_ip and (dns_query from2 15)="" and (dns_query from2 1)=""
171	suspicious += " domain" ; comments += "Sender domain is suspicious."
172	session auto_from := from
173	eif (l parse acpattern:"To:" any:(var Str tos)) or (l parse acpattern:"Cc:" any:(var Str tos))
174	while tos<>""
175	if not (tos parse any:(var Str to) "," any:(var Str remain))
176	to := tos ; remain := ""
177	if exists:(session:to_confirmed first ac_real_email:to)
178	session:to_confirmed ac_real_email:to := true
179	tos := remain
180	eif (l parse acpattern:"Received:" any "(" any ")" word:"by" any:(var Str srv) ";" any)
181	if srv=session:local_name
182	loop += 1
183	if loop>1
184	a := "559 The mail is looping between SMTP servers."
185	eif (l parse acpattern:"Subject:" any:(var Str subject))
186	session auto_subject := subject
187	eif (l parse acpattern:"Message-ID:" any:(var Str messageid))
188	session auto_messageid := messageid
189	if (l 0 2)=".."
190	l := l 1 l:len
191	mail writeline l
192	session:log trace "header " l
193	plugin mail_header_line
194	if session:check_to
195	var Pointer:CBool c :> session:to_confirmed first
196	while exists:c
197	if not c
198	suspicious += " to" ; comments += "Recipients list is suspicious." # 'To:' or 'Cc:' is missing or wrong in the mail header.
199	c :> session:to_confirmed next c
200	if session:check_from
201	if session:from<>"" and not from_provided
202	suspicious += " from" ; comments += "This mail might come from "+session:from
203	if suspicious<>""
204	mail writeline "Suspicious:"+suspicious
205	if empty_line
206	mail writeline l
207	if (exists comments:first) and not session:magic
208	if session:outmail<>""
209	if a=""
210	a := "553 "+comments:first
211	else
212	mail writeline "Mail agent comments:"
213	var Pointer:Str comment :> comments first
214	while exists:comment
215	mail writeline "  "+comment
216	comment :> comments next comment
217	mail writeline ""
218	var CBool empty := true
219	if l<>"."
220	while not s:atend and { var Str l := s readline ; l<>"." }
221	if (l 0 2)=".."
222	l := l 1 l:len
223	mail writeline l
224	if l<>""
225	empty := false
226	if session:auto_subject="" and empty
227	session spam_level := 1
228	if s=failure
229	a := "458 Broken TCP connection"
230	if mail:close=failure and a=""
231	a := "452 Requested action not taken: insufficient system storage"
232	if use_spam_filter and not session:magic
233	var Pointer:Str sf :> session:spam_filters first
234	while exists:sf and session:spam_level<1
235	session spam_level := max session:spam_level (spam_filter filename sf)
236	sf :> session:spam_filters next sf
237
238
239	method session receive_mail s -> a
240	arg_rw SmtpSession session ; arg_rw Stream s ; arg Str a
241	var CBool stored := false
242	var CBool failed := false
243	var Str forwards
244	var Str temp
245	a := "550 Rejected without any explaination"
246	part store
247	var Pointer:SmtpFile c :> session:files first
248	while exists:c
249	if not stored
250	a := "354 Start mail input; end with <CRLF>.<CRLF>"
251	s writeline a
252	session:log trace "answer " a
253	temp := (session:files key c)+".tmp"
254	a := session receive_mail_content s temp
255	if a<>""
256	leave store
257	stored := true
258	else
259	if (file_clone temp (session:files key c)+".tmp")=failure and (file_copy temp (session:files key c)+".tmp")=failure
260	failed := true
261	a := "451 Requested action aborted: local error in processing"
262	leave store
263	if (exists c:to:first)
264	var (Link Database:MailMeta) db :> new Database:MailMeta
265	db load (session:files key c)+".pdb"
266	var Data:MailMeta meta :> db data
267	meta queued_on := datetime
268	meta from := session from
269	var Pointer:Str t :> c:to first ; var Int i := 1
270	while exists:t
271	meta:target create string:i
272	meta:target:(string:i):box := t
273	t :> c:to next t ; i += 1
274	if c:push
275	meta push
276	if db:store=failure
277	session:log trace "failed to store meta datas for " session:id " in " (session:files key c)+".pdb"
278	forwards += string (session:files key c)+".mail"
279	c :> session:files next c
280	if stored and not failed
281	session:log trace "session ID is " session:id
282	var Pointer:SmtpFile c :> session:files first
283	while exists:c
284	if (exists c:to:first) or not c:forward
285	var Str mail := (session:files key c)+".mail"
286	if use_spam_filter and session:spam_level>=0 and (reverse:mail eparse any:(var Str tail) (pattern reverse:"/in/") any:(var Str head)) and (tail search "/" -1)=(-1)
287	set_spam_mark (session:files key c)+".tmp" true
288	mail := reverse:head+(shunt session:spam_level>0 "/spam/" "/unknown/")+reverse:tail
289	file_tree_create mail
290	file_move (session:files key c)+".tmp" mail
291	file_directory_flush mail
292	plugin just_received
293	# within your plugin, you can scan all receipients of the mail
294	# through something like:
295	#   var Pointer:Str to :> c:to first
296	#   while exists:to
297	#     ...
298	#     to :> c:to next to
299	file_hook mail
300	else
301	file_delete (session:files key c)+".tmp"
302	c :> session:files next c
303	a := "250 OK"
304	if forwards<>""
305	forward_mails
306	if (forward_immediat nowait_request 1)
307	safe
308	thread
309	while (forwards parse (var Str forward) any:(var Str remain))
310	forward_mail forward
311	forwards := remain
312	forward_immediat release 1
313	failure
314	forward_immediat release 1
315	else
316	var Pointer:SmtpFile c :> session:files first
317	while exists:c
318	file_delete (session:files key c)+".tmp"
319	file_delete (session:files key c)+".pdb"
320	c :> session:files next c
321
322
323	method smtp service s
324	arg_rw SmtpServer smtp ; arg_rw Stream s
325	var SmtpSession session
326	session:log bind smtp_trace
327	session remote_ip := s query "remote_ip_address"
328	var DateTime timestamp := datetime
329	timestamp split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction)
330	session:log trace "SMTP connection start at " timestamp " from " session:remote_ip
331	part dialog "SMTP connection from "+session:remote_ip+" (started at "+string:timestamp+")"
332	each ip mail_database:data:magic_ip
333	if (session:remote_ip is_inside_ip_domain keyof:ip)
334	session remote_magic := true
335	if not session:remote_magic
336	each ip mail_database:data:black_ip
337	if (session:remote_ip is_inside_ip_domain keyof:ip)
338	s writeline "559 you are blacklisted on this site."
339	session:log trace "remote IP is blacklisted on this site."
340	leave dialog
341	if (session:remote_ip parse (var Int ip1) "." (var Int ip2) "." (var Int ip3) "." (var Int ip4))
342	each dns mail_database:data:black_dns
343	if (dns_query string:ip4+"."+string:ip3+"."+string:ip2+"."+string:ip1+"."+keyof:dns)<>""
344	s writeline "559 you are blacklisted on "+keyof:dns+" ("+(dns_query string:ip4+"."+string:ip3+"."+string:ip2+"."+string:ip1+"."+keyof:dns 16)+")"
345	session:log trace "remote IP is blacklisted on "+keyof:dns
346	leave dialog
347	session local_name := this_computer:env:"pliant":"mail":"smtp_name"
348	if session:local_name=""
349	session local_name := computer_fullname
350	s writeline "220 "+session:local_name+" Simple Mail Transfer Service Ready"
351	session:log trace "welcome 220 "+session:local_name+" Simple Mail Transfer Service Ready"
352	while not s:atend
353	var Str l := s readline
354	session:log trace "query " l
355	if (l parse any:(var Str first) _ any:(var Str second2) ":" any:(var Str remain))
356	l := upper:first+" "+upper:second2+":"+remain
357	eif (l parse any:(var Str first) _ any:(var Str remain))
358	l := upper:first+" "+remain
359	else
360	l := upper l
361	var Str a
362	if (l parse word:"HELO" (any session:remote_name))
363	if exists:(mail_database:data:magic_name session:remote_name)
364	session remote_magic := true
365	session welcome := true
366	eif exists:(mail_database:data:black_name session:remote_name)
367	session welcome := false
368	else
369	session welcome := true
370	a := shunt session:welcome "250 "+session:local_name "550 No mail will be accepted here"
371	session reset
372	plugin command_helo
373	eif (l parse word:"MAIL" word:"FROM" ":" any:(var Str from))
374	var Str from2 := ac_real_email from
375	if exists:(mail_database:data:magic_from from2)
376	session magic := true
377	eif exists:(mail_database:data:black_from from2)
378	session rejected := true
379	from2 := from2 (from2 search "@" from2:len)+1 from2:len
380	if exists:(mail_database:data:magic_from from2)
381	session magic := true
382	eif exists:(mail_database:data:black_from from2)
383	session rejected := true
384	var Data:MailBox b :> mailbox real_email:from
385	if not exists:b
386	b :> mailbox ac_real_email:from
387	if not session:welcome or session:rejected
388	a := "550 No mail will be accepted here"
389	eif session:from<>""
390	session rejected := true
391	a := "503 Bad sequence of commands"
392	eif computer_fullname=b:computer and b:smtp_ip<>"" and (session:remote_ip is_inside_ip_domain b:smtp_ip)
393	# out mail from the mailbox owner
394	session from := from
395	session outmail := b out_path
396	var Pointer:SmtpFile file :> session add_file b:out_path+session:id ""
397	file forward := true
398	if b:archive and session:remote_name<>computer_fullname
399	session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
400	session check_from_to b
401	a := "250 OK"
402	eif computer_fullname=b:relay_computer and session:remote_ip=(dns_query_prototype b:computer dns_query_function)
403	# out mail in the relay computer from the mailbox server computer
404	session from := from
405	session outmail := b relay_path
406	var Pointer:SmtpFile file :> session add_file b:relay_path+session:id ""
407	file forward := true
408	if b:relay_archive and session:remote_name<>computer_fullname
409	session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
410	session check_from_to b
411	a := "250 OK"
412	else
413	session from := from
414	a := "250 OK"
415	plugin command_from
416	eif (l parse word:"RCPT" word:"TO" ":" any:(var Str to))
417	var Str real_to := real_email to
418	var Data:MailBox b :> mailbox real_to
419	if not exists:b
420	real_to := ac_real_email to
421	b :> mailbox real_to
422	if not session:welcome or session:rejected
423	a := "550 No mail will be accepted here"
424	eif computer_fullname=b:computer
425	if b:list
426	# mailing list
427	session accepted := true
428	if b:subscriber:size>0
429	var Pointer:SmtpFile file :> session add_file b:out_path+session:id to
430	each ms b:subscriber
431	file to += ms
432	file forward := true
433	file push := true
434	if b:archive
435	session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
436	session check_from_to b
437	a := "250 OK"
438	else
439	# in mail
440	session accepted := true
441	session add_file b:in_path+session:id to
442	if b:archive
443	session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
444	session check_from_to b
445	if use_spam_filter and (file_query (b smart_path "")+"spam_filter.txt" standard)=defined
446	session spam_filters += (b smart_path "")+"spam_filter.txt"
447	a := "250 OK"
448	if b:auto_answer<>""
449	session auto_to += " "+b:name+" <"+keyof:b+">" ; session auto_answer += b:auto_answer+"[lf]"
450	eif computer_fullname=b:relay_computer
451	# in mail in the relay computer
452	session accepted := true
453	var Pointer:SmtpFile file :> session add_file b:relay_path+session:id to
454	file to += to
455	file forward := true
456	if b:relay_archive
457	session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
458	session check_from_to b
459	a := "250 OK"
460	if b:auto_answer<>""
461	session auto_to += " "+b:name+" <"+keyof:b+">" ; session auto_answer += b:auto_answer+"[lf]"
462	eif session:outmail<>""
463	if session:remote_name<>computer_fullname
464	session accepted := true
465	var Pointer:SmtpFile file :> session add_file session:outmail+session:id to
466	file to += to
467	a := "250 OK"
468	else
469	a := "550 the target mailbox is probably wrong (I'm trying to forward to myself !)"
470	else
471	a := "550 Mails to "+to+" are not accepted here"
472	plugin command_to
473	if a="250 OK"
474	session to += real_to
475	eif l="DATA"
476	if not session:welcome or session:rejected
477	a := "550 No mail will be accepted here"
478	eif not session:accepted
479	a := "503 Bad sequence of commands"
480	else
481	a := ""
482	plugin command_data
483	if a=""
484	a := session receive_mail s
485	if a="250 OK" and session:auto_answer<>"" and session:auto_from<>"" and (not use_spam_filter or session:spam_level<0)
486	(var Stream answer) open "smtp:"+session:auto_from "subject "+(string session:auto_subject)+(shunt session:auto_messageid<>"" " references "+(string session:auto_messageid) "")+" timeout "+string:smtp_auto_answer_timeout out+safe
487	answer writeline "Here is an automatic answer related to"+session:auto_to+":"
488	answer writeline ""
489	answer writechars session:auto_answer
490	answer close
491	session reset
492	eif pattern_matching and (l parse word:"VRFY" any:(var Str pattern))
493	var Data:MailBox b :> mailbox real_email:pattern
494	if exists:b
495	a := "250 "+b:name+" <"+keyof:b+">"
496	else
497	var Int count := 0
498	each b mailbox
499	if ((lower b:name+" <"+keyof:b+">") search lower:pattern -1)<>(-1)
500	count += 1
501	a := "250 "+b:name+" <"+keyof:b+">"
502	if count=0
503	a := "550 String does not match anything"
504	eif count>1
505	a := "553 User ambiguous"
506	plugin command_vrfy
507	eif l="RSET"
508	session reset
509	a := "250 OK"
510	eif l="NOOP"
511	a := "250 OK"
512	eif l="QUIT"
513	a := "221 "+session:local_name+" Service closing transmission channel"
514	else
515	a := "502 Command not implemented"
516	plugin not_implemented
517	s writeline a
518	session:log trace "answer " a
519	if l="QUIT"
520	leave dialog
521	session:log trace "SMTP connection stop at " datetime " from " session:remote_ip
522
523
524	define_tcp_server SmtpServer smtp_server
525	export smtp_server
526
527