/pliant/protocol/smtp/forward.pli
1	abstract
2	[The 'forward_message' function will attempt to forward a mail to the next SMTP server.]
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/language/compiler.pli"
20	module "/pliant/language/stream.pli"
21	module "/pliant/language/context.pli"
22	module "/pliant/fullpliant/this_computer.pli"
23	module "/pliant/storage/database.pli"
24	module "/pliant/admin/file.pli"
25	module "mail.pli"
26	module "meta.pli"
27	module "/pliant/protocol/dns/client.pli"
28	module "/pliant/language/schedule/namedsem.pli"
29	module "/pliant/language/schedule/resourcesem.pli"
30	module "/pliant/language/schedule/daemon.pli"
31
32	constant verbose true
33	constant forward_timeout 300
34
35	gvar NamedSem forward_sem
36	public
37	(gvar ResourceSem forward_immediat) configure 16
38
39	(gvar TraceSlot forward_trace) configure "SMTP forwarder"
40
41
42
43
44
45	function forward_path mailto route -> computers
46	arg Str mailto route computers
47	if not (mailto parse any "<" any:(var Str to) ">" any)
48	mailto parse any:to
49	var Data:MailBox box :> mailbox to
50	if exists:box
51	return box:computer
52	box :> mailbox lower:to
53	if exists:box
54	return box:computer
55	if route<>""
56	return route
57	computers := this_computer:env:"pliant":"mail":"forward_route"
58	if computers<>""
59	return
60	var Str domain := to (to search "@" -1)+1 to:len
61	computers := dns_query domain 15
62	if computers=""
63	computers := dns_query domain 1
64
65
66
67
68
69	function backward_mail filename -> status
70	arg Str filename ; arg Status status
71	forward_trace trace "backwarding " filename
72	var (Link Database:MailMeta) db :> new Database:MailMeta
73	db load (replace filename ".mail" ".pdb")
74	var Data:MailMeta meta :> db data
75	if meta:from=""
76	file_delete filename
77	file_delete (replace filename ".mail" ".pdb")
78	file_directory_flush filename
79	file_hook filename
80	file_hook (replace filename ".mail" ".pdb")
81	return
82	(var Stream dest) open (replace filename ".mail" ".tmp") out+safe
83	dest writeline "Subject: Mail delivery failure"
84	dest writeline "To: "+meta:from
85	dest writeline ""
86	each target meta:target
87	if target:status<>"S"
88	dest writeline "Could not send the mail to "+target:box
89	dest writeline "Tryed "+(string target:try_count)+" times."
90	dest writeline "At the last try, on "+(string target:last_server)
91	dest writeline "SMTP server '"+target:last_server+"' reported the following"+(shunt target:status="R" " fatal" "")+" error:"
92	dest writeline target:last_error
93	dest writeline ""
94	dest writeline "The beginning of the mail was: "
95	(var Stream src) open filename in+safe
96	while not src:atend and src:line_number<60
97	dest writeline src:readline
98	src close ; dest close
99	var Str from := meta from
100	data_reset meta
101	meta:target create ""
102	meta:target:"":box := from
103	db store
104	file_delete filename ; file_move (replace filename ".mail" ".tmp") filename
105	file_directory_flush filename
106	file_hook filename
107
108
109	function command s cmd answer log -> c
110	arg_rw Stream s ; arg Str cmd ; arg_w Str answer ; arg_rw TraceSession log ; arg Int c
111	if cmd<>""
112	s writeline cmd
113	log trace "query " cmd
114	answer := s readline
115	log trace "answer " answer
116	if s=failure
117	return 458
118	while (answer parse c "-" any)
119	answer := s readline
120	log trace "answer " answer
121	if not (answer parse c _ any)
122	return (shunt answer="" 459 509)
123
124	function command s cmd log -> c
125	arg_rw Stream s ; arg Str cmd ; arg_w TraceSession log ; arg Int c
126	c := command s cmd (var Str answer) log
127
128	function command s cmd comment msg fatal log -> escape
129	arg_rw Stream s ; arg Str cmd comment ; arg_rw Str msg ; arg_rw CBool fatal ; arg_rw TraceSession log ; arg CBool escape
130	var Int err := command s cmd  (var Str answer) log
131	escape := err>=400
132	if escape
133	msg := comment+": "+answer
134	if err>=500
135	fatal := true
136
137	function conforming_name n -> c
138	arg Str n c
139	if not (n parse any "<" any:(var Str m) ">" any)
140	n parse any:m
141	c := "<"+m+">"
142
143
144	function forward_to_server filename meta server target -> status
145	arg Str filename ; arg_rw Data:MailMeta meta ; arg Str server ; arg_rw Data:MailMetaTarget target ; arg Status status
146	(var TraceSession log) bind forward_trace
147	log trace "forwarding " filename " to " server
148	var CBool direct := meta direct
149	var Str route := meta route
150	var List:Str ontheway
151	if exists:target
152	ontheway += keyof target
153	else
154	each t meta:target
155	if t:status=" "
156	part scan_computers
157	var Str computers := forward_path t:box route
158	while computers<>""
159	if not (computers parse any:(var Str computer) _ any:(var Str remain))
160	computer := computers ; remain := ""
161	if computer=server
162	ontheway += keyof t
163	leave scan_computers
164	if direct
165	leave scan_computers
166	computers := remain
167	var DateTime timestamp := datetime
168	var Pointer:Str id :> ontheway first
169	while exists:id
170	var Data:MailMetaTarget t :> meta:target:id
171	t try_count += 1
172	t last_try := timestamp
173	t last_server := server
174	t last_error := "sending"
175	id :> ontheway next id
176	status := failure
177	var CBool some := false ; var Str msg := "Pliant internal bug" ; var CBool fatal := false
178	part talk
179	var Str ip := dns_query server 1
180	if ip=""
181	log trace "could not find IP address of " server
182	msg := "could not find IP address of "+server
183	leave talk
184	(var Stream tcp) open "tcp://"+ip+"/client/25" in+out+safe+cr+lf
185	if tcp=failure
186	log trace "failed to connect to " server " SMTP TCP port"
187	msg := "failed to connect to "+server+" SMTP TCP port"
188	leave talk
189	tcp configure "priority low"
190	tcp configure "timeout "+string:forward_timeout
191	if (command tcp "" "server did not welcome us" msg fatal log)
192	leave talk
193	var Str smtp_name := this_computer:env:"pliant":"mail":"smtp_name"
194	if smtp_name=""
195	smtp_name := computer_fullname
196	if (command tcp "HELO "+smtp_name "server rejected our greeting" msg fatal log)
197	leave talk
198	if meta:from<>""
199	if (command tcp "MAIL FROM:"+(conforming_name meta:from) "server rejected our from specification" msg fatal log)
200	leave talk
201	var Pointer:Str id :> ontheway first
202	while exists:id
203	var Data:MailMetaTarget t :> meta:target:id
204	var Int err := command tcp "RCPT TO:"+(conforming_name t:box) (var Str answer) log
205	if err<300
206	some := true
207	else
208	t last_error := shunt (answer parse word:"sending" any) "- "+answer+" -" answer
209	if err>=500
210	t status := "R"
211	id :> ontheway next id
212	if not some
213	msg := "no recipient for the message."
214	leave talk
215	if (command tcp "DATA" "server rejected the mail (at beginning)" msg fatal log)
216	leave talk
217	if exists:target
218	tcp writeline "To: "+target:box
219	if verbose
220	var Intn total := (file_query filename standard) size
221	(var Stream mail) open filename in+safe
222	while not mail:atend
223	var Str l := mail readline
224	if (l 0 1)="."
225	l := "."+l
226	tcp writeline l
227	if verbose and (mail:line_number .and. 255)=1
228	if ((mail query "seek") parse (var Intn offset))
229	var Pointer:Str id :> ontheway first
230	while exists:id
231	var Data:MailMetaTarget t :> meta:target:id
232	if (t:last_error parse word:"sending" any)
233	t last_error := "sending "+string:(cast 100*offset\total Int)+"%"
234	id :> ontheway next id
235	if (command tcp "." "server rejected the mail (at end)" msg fatal log)
236	leave talk
237	command tcp "QUIT" log
238	status := success
239	tcp close
240	var Pointer:Str id :> ontheway first
241	while exists:id
242	var Data:MailMetaTarget t :> meta:target:id
243	if (t:last_error parse word:"sending" any)
244	if status=success
245	t status := "S"
246	t last_error := ""
247	else
248	t last_error := msg
249	if fatal
250	t status := "R"
251	id :> ontheway next id
252
253
254	function forward_mail filename -> status
255	arg Str filename ; arg Status status
256	forward_sem request filename
257	part do_forward "forwarding mail "+filename
258	if (file_query filename standard)=defined
259	forward_trace trace "forwarding " filename
260	var (Link Database:MailMeta) db :> new Database:MailMeta
261	db load (replace filename ".mail" ".pdb")
262	var Data:MailMeta meta :> db data
263	var CBool split := meta split
264	var CBool direct := meta direct
265	var Str route := meta route
266	if split and meta:threads>1
267	parallel threads meta:threads
268	each t meta:target
269	if t:status=" " and not daemon_emergency
270	task
271	part forward_to_one
272	var Str computers := forward_path t:box route
273	if computers=""
274	forward_trace trace "no mail server or wrong domain for " t:box
275	t try_count += 1
276	t last_try := datetime
277	t last_server := ""
278	t last_error := "no mail server or wrong domain"
279	while computers<>""
280	if not (computers parse any:(var Str computer) _ any:(var Str remain))
281	computer := computers ; remain := ""
282	if (forward_to_server filename meta computer t)=success
283	leave forward_to_one
284	if direct
285	leave forward_to_one
286	computers := remain
287	else
288	var (Dictionary Str Void) tryed
289	each t meta:target
290	part forward_to_one
291	if t:status<>" " or daemon_emergency
292	leave forward_to_one
293	var Str computers := forward_path t:box route
294	if computers=""
295	forward_trace trace "no mail server or wrong domain for " t:box
296	t try_count += 1
297	t last_try := datetime
298	t last_server := ""
299	t last_error := "no mail server or wrong domain"
300	while computers<>""
301	if not (computers parse any:(var Str computer) _ any:(var Str remain))
302	computer := computers ; remain := ""
303	if split
304	if (forward_to_server filename meta computer t)=success
305	leave forward_to_one
306	else
307	if not exists:(tryed first computer)
308	tryed insert computer void
309	if (forward_to_server filename meta computer (var Data:MailMetaTarget empty_target))=success
310	leave forward_to_one
311	if direct
312	leave forward_to_one
313	computers := remain
314	status := success ; var Int success_count := 0 ; var Int total_count := 0
315	var CBool try_again := datetime:seconds-meta:queued_on:seconds<meta:try_period
316	each t meta:target
317	if t:status<>"S"
318	status := failure
319	if t:status=" " and t:try_count<meta:try_times
320	try_again := true
321	else
322	success_count += 1
323	total_count += 1
324	db store
325	var CBool surrender := not try_again and not meta:report
326	var CBool removed := (file_query filename standard)=undefined
327	if status=success or surrender or removed
328	forward_trace trace "removing " filename+" (forwarded "+string:success_count+"/"+string:total_count+(shunt surrender " surrender" "")+(shunt removed " removed" "")+")"
329	file_delete filename
330	file_delete (replace filename ".mail" ".pdb")
331	file_directory_flush filename
332	file_hook filename
333	file_hook (replace filename ".mail" ".pdb")
334	eif not try_again
335	backward_mail filename
336	forward_sem release filename
337
338	function forward_mail filename detached action -> status
339	arg Str filename ; arg CBool detached ; arg Str action ; arg Status status
340	if (forward_immediat nowait_request 1)
341	if detached
342	status := success
343	safe
344	thread
345	part async_forward action
346	forward_mail filename
347	forward_immediat release 1
348	failure
349	forward_immediat release 1
350	status := failure
351	else
352	part sync_forward action
353	status := forward_mail filename
354	forward_immediat release 1
355	else
356	forward_trace trace "fowarding delayed because all forwarding slots are currently in use"
357
358
359	function forward_path filename route options
360	arg Str filename ; arg Str route options
361	forward_sem request filename
362	if (file_query filename standard)=defined
363	var (Link Database:MailMeta) db :> new Database:MailMeta
364	db load (replace filename ".mail" ".pdb")
365	db:data route := route
366	if (options option "direct")
367	db:data direct := true
368	if (options option "indirect")
369	db:data direct := false
370	if (options option "split")
371	db:data direct := true
372	if (options option "group")
373	db:data direct := false
374	db store
375	forward_sem release filename
376
377
378
379
380
381	function forward_mails
382	if (this_computer:env:"pliant":"mail":"forward_immediat" parse (var Int n))
383	forward_immediat configure n
384	daemon "mails forwarder daemon"
385	var CBool again := true
386	while again and not daemon_emergency
387	again := false
388	if not (this_computer:env:"pliant":"mail":"forward_sleep" parse (var Float f))
389	f := 3600
390	daemon_sleep f
391	if not daemon_emergency
392	var (Dictionary Str CBool) done_path := var (Dictionary Str CBool) empty_dictionary
393	if not (this_computer:env:"pliant":"mail":"forward_threads" parse (var Int n))
394	n := 1
395	parallel threads n
396	each box mailbox
397	var Str path
398	if box:computer=computer_fullname
399	path := box out_path
400	eif box:relay_computer=computer_fullname
401	path := box relay_path
402	else
403	path := ""
404	if path<>"" and not exists:(done_path first path) and pliant_execution_phase<=execution_phase_run
405	done_path insert path true
406	var Array:FileInfo files := file_list path standard
407	for (var Int i) 0 files:size-1
408	if files:i:extension=".mail" and not daemon_emergency
409	again := true
410	var Str name := files:i name
411	task
412	forward_mail name
413
414	forward_mails
415
416
417	export forward_mail forward_mails forward_path