/pliant/protocol/smtp/client.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	module "/pliant/language/unsafe.pli"
17	module "/pliant/language/context.pli"
18	module "/pliant/language/stream.pli"
19	module "/pliant/language/stream/multi.pli"
20	module "/pliant/language/stream/filesystembase.pli"
21	module "/pliant/language/stream/openmode.pli"
22	module "/pliant/language/stream/flushmode.pli"
23	module "/pliant/fullpliant/this_computer.pli"
24	module "/pliant/protocol/dns/client.pli"
25
26	constant extended false
27	constant default_timeout 300
28	constant trace false
29
30	(gvar TraceSlot smtp_trace) configure "SMTP client"
31
32
33	if extended
34
35	function command s cmd extra log -> c
36	arg_rw Stream s ; arg Str cmd ; arg_w Str extra ; arg_rw TraceSession log ; arg Int c
37	if cmd<>""
38	s writeline cmd
39	log trace "query " cmd
40	var Str l := s readline
41	log trace "answer " l
42	if s=failure
43	return 599
44	extra := ""
45	while (l parse c "-" any:(var Str remain))
46	l := s readline
47	log trace "answer " l
48	if (l parse c _ any:(var Str remain)) or (l parse c _ any:(var Str remain))
49	extra += " "+remain
50	if not (l parse c _ any:(var Str remain))
51	return 598
52
53	function command s cmd log -> c
54	arg_rw Stream s ; arg Str cmd ; arg_rw TraceSession log ; arg Int c
55	c := command s cmd (var Str extra) log
56
57	else
58
59	function command s cmd log -> c
60	arg_rw Stream s ; arg Str cmd ; arg_rw TraceSession log ; arg Int c
61	if cmd<>""
62	if trace
63	console "-> " cmd eol
64	s writeline cmd
65	log trace "query " cmd
66	var Str l := s readline
67	if trace
68	console "<- " l eol
69	log trace "answer " l
70	if s=failure
71	return 599
72	while (l parse c "-" any:(var Str remain))
73	l := s readline
74	if trace
75	console "<- " l eol
76	log trace "answer " l
77	if not (l parse c _ any:(var Str remain))
78	return 598
79
80
81	type SmtpFileSystem
82	void
83	FileSystem maybe SmtpFileSystem
84
85	type SmtpStreamDriver
86	field Link:Stream tcp
87	field Link:TraceSession log
88	StreamDriver maybe SmtpStreamDriver
89
90	method smtp write buf mini maxi -> written
91	arg_rw SmtpStreamDriver smtp ; arg Address buf ; arg Int mini maxi written
92	written := smtp:tcp:stream_driver write buf mini maxi
93
94	method smtp flush level -> status
95	arg_rw SmtpStreamDriver smtp ; arg Int level ; arg Status status
96	status := smtp:tcp:stream_driver flush level
97
98	method smtp close -> status
99	arg_rw SmtpStreamDriver smtp ; arg ExtendedStatus status
100	status := success
101	if (command smtp:tcp "." smtp:log)>=300
102	status := failure
103	if (command smtp:tcp "QUIT" smtp:log)>=300
104	status := failure
105	smtp:tcp flush end
106	if smtp:tcp=failure
107	status := failure
108	smtp:tcp close
109
110	method smtp query command stream answer -> status
111	arg_rw SmtpStreamDriver smtp ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status
112	status := smtp:tcp:stream_driver query command smtp:tcp answer
113
114	method smtp configure command stream -> status
115	arg_rw SmtpStreamDriver smtp ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status
116	status := smtp:tcp:stream_driver configure command smtp:tcp
117
118	function conforming_name n -> c
119	arg Str n c
120	if not (n parse any "<" any:(var Str m) ">" any)
121	n parse any:m
122	c := "<"+m+">"
123
124	method fs open name options flags stream support -> status
125	arg_rw SmtpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
126	var DateTime dt := datetime
127	if (flags .and. in_out)<>out
128	return failure
129	var Link:Stream tcp :> new Stream
130	var Str servers := options option "server" Str
131	if servers="" and ( (name parse any "@" any:(var Str domain) ">" any) or (name parse any "@" any:(var Str domain) "(" any) or (name parse any "@" any:(var Str domain)) )
132	var Str servers := dns_query domain 15
133	if servers=""
134	servers := dns_query domain 1
135	if servers=""
136	servers := this_computer:env:"pliant":"mail":"smtp_provider"
137	part connect
138	while tcp=failure and servers<>""
139	if not (servers parse any:(var Str server) _ any:(var Str remain))
140	server := servers ; remain := ""
141	tcp open "tcp:"+(shunt server<>"" "//"+server "")+"/client/25" in+out+cr+lf+safe
142	servers := remain
143	if tcp=failure
144	if trace
145	console "Failed to open channel " tcp:name eol
146	smtp_trace trace "Failed to open channel " tcp:name
147	return failure
148	tcp configure "timeout "+string:(options option "timeout" Int default_timeout)
149	var Link:TraceSession log :> new TraceSession
150	log bind smtp_trace
151	if (command tcp "" log)>=300
152	return failure
153	var Str myname := options option "myname" Str
154	if myname="" and computer_name<>"" and computer_domain<>""
155	myname := computer_name+"."+computer_domain
156	if myname=""
157	myname := tcp query "local_ip_address"
158	if extended
159	var Str capabilities
160	if (command tcp "EHLO "+myname capabilities log)>=300
161	if (command tcp "HELO "+myname log)>=300
162	return failure
163	else
164	if (command tcp "HELO "+myname log)>=300
165	return failure
166	var Str from := options option "from" Str
167	if from<>""
168	if (command tcp "MAIL FROM:"+conforming_name:from log)>=300
169	return failure
170	var Str to := name
171	if to<>""
172	if (command tcp "RCPT TO:"+conforming_name:to log)>=300
173	return failure
174	var Int i := 0
175	while { var Str to2 := options option "to" i Str ; to2<>"" }
176	if (command tcp "RCPT TO:"+conforming_name:to2 log)>=300
177	return failure
178	i += 1
179	var Int i := 0
180	while { var Str to2 := options option "cc" i Str ; to2<>"" }
181	if (command tcp "RCPT TO:"+conforming_name:to2 log)>=300
182	return failure
183	i += 1
184	status := success
185	var Int i := 0
186	while { var Str file := options option "mailing" i Str ; file<>"" }
187	(var Stream mailing) open file in+safe
188	while not mailing:atend
189	var Str l := mailing readline
190	if not l:parse
191	if (command tcp "RCPT TO:"+conforming_name:l log)>=300
192	status := failure
193	mailing close
194	i += 1
195	if (command tcp "DATA" log)>=400
196	return failure
197	if not (options option "noheader")
198	tcp writeline "Date: "+("SunMonTueWedThuFriSat" dt:day_of_week*3 3)+", "+(string dt:day)+" "+("JanFebMarAprMayJunJulAugSepOctNovDec" 3*dt:month-3 3)+" "+(right (string dt:year) 4 "0")+" "+(right (string dt:hour) 2 "0")+":"+(right (string dt:minute) 2 "0")+":"+(right (string dt:second) 2 "0")+" +0000"
199	if from<>""
200	tcp writeline "From: "+from
201	if to<>""
202	tcp writeline "To: "+to
203	var Int i := 0
204	while { var Str to2 := options option "to" i Str ; to2<>"" }
205	tcp writeline "To: "+to2
206	i += 1
207	var Int i := 0
208	while { var Str to2 := options option "cc" i Str ; to2<>"" }
209	tcp writeline "CC: "+to2
210	i += 1
211	var Str subject := options option "subject" Str
212	if subject<>""
213	tcp writeline "Subject: "+subject
214	var Str references := options option "references" Str
215	if references<>""
216	tcp writeline "References: "+references
217	var Str mime := options option "mime" Str
218	if mime<>""
219	tcp writeline "Content-Type: "+mime
220	tcp writeline ""
221	tcp flush anytime
222	var Link:SmtpStreamDriver smtp :> new SmtpStreamDriver
223	smtp tcp :> tcp
224	smtp log :> log
225	stream stream_driver :> smtp
226	stream stream_flags := stream:stream_flags .or. cr+lf
227
228
229	gvar SmtpFileSystem smtp_file_system
230	pliant_multi_file_system mount "smtp:" "" smtp_file_system
231