/pliant/protocol/ftp/server.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	abstract
17	[This is Pliant FTP server implementation (RFC 959)]
18
19	module "/pliant/install/minimal.pli"
20	module "/pliant/language/unsafe.pli"
21	module "/pliant/language/context.pli"
22	module "/pliant/language/compiler.pli"
23	module "/pliant/language/stream.pli"
24	module "/pliant/admin/file.pli"
25	module "/pliant/admin/md5.pli"
26	submodule "/pliant/protocol/common/tcp_server.pli"
27	module "/pliant/protocol/common/misc.pli"
28	module "/pliant/protocol/http/site.pli"
29	module "/pliant/fullpliant/user.pli"
30	module "/pliant/fullpliant/login.pli"
31	module "/pliant/language/os/socket.pli"
32
33
34	constant passive true
35	constant active true
36
37	(gvar TraceSlot ftp_trace) configure "FTP server"
38
39
40	public
41	type FtpServer
42	tcp_server_fields "FTP" 21
43	field CBool send_software_release_number <- true
44	field CBool unix_style <- true
45	TcpServer maybe FtpServer
46
47	type FtpEnv
48	field Pointer:FtpServer server
49	field Link:Stream command
50	field Stream data
51	field Data:Site site
52	field Str user <- "" ; field Int user_auth_level <- 0
53	field Dictionary rights
54	field Str port
55	field Str cwd <- "/"
56	field TraceSession log
57
58
59	method env writeline line
60	arg_rw FtpEnv env ; arg Str line
61	env:command writeline line
62	env:log trace "answer " line
63
64	method env try_site site -> status
65	arg_rw FtpEnv env ; arg Data:Site site ; arg Status status
66	if not exists:site
67	return failure
68	if site:computer<>computer_fullname and site:computer<>""
69	return failure
70	if site:protocol<>"FTP"
71	return failure
72	var Str ip := env:command query "local_ip_address"
73	if ip<>"" and site:ip<>ip and site:ip<>""
74	return failure
75	if ((env:command query "local_ip_port") parse (var Int port)) and site:port<>port and site:port=defined
76	return failure
77	env:log trace "site is " keyof:site
78	env site :> site
79	status := success
80
81	method env assign_rights uname ip rights
82	arg_rw FtpEnv env ; arg Str uname ip ; arg_rw Str rights
83	var Data:User u :> user uname
84	each r u:right
85	if (string env:user_auth_level)>=r:auth and (ip is_inside_ip_domain r:ip) and (r:server="" or (" "+r:server+" " search " "+computer_fullname+" " -1)<>(-1))
86	env:rights kmap r:right CBool := true
87	rights += " "+r:right
88
89	method env assign_user
90	arg_rw FtpEnv env
91	env rights := var Dictionary empty_dictionary
92	var Str ruser := env:command safe_query "remote_user"
93	if ruser<>""
94	env user := ruser
95	env user_auth_level := 3
96	env site :> site (env:command safe_query "local_user")
97	else
98	part scan_for_site
99	each s site
100	if s:protocol="FTP" and (s:computer<>"" or s:ip<>"")
101	if (env try_site s)=success
102	leave scan_for_site
103	each s site
104	if s:ip<>""
105	if (env try_site s)=success
106	leave scan_for_site
107	each s site
108	if s:computer<>""
109	if (env try_site s)=success
110	leave scan_for_site
111	each s site
112	if (env try_site s)=success
113	leave scan_for_site
114	return
115	var Str rights
116	var Str ip := env:command query "remote_ip_address"
117	env assign_rights "anonymous" ip rights
118	each t (user env:user):template
119	env assign_rights t ip rights
120	if env:user<>""
121	env assign_rights env:user ip rights
122	env:log trace "user " env:user " " env:user_auth_level " :" rights
123	if env:user<>""
124	if not (login_record env:user ip "FTP "+(string env:user_auth_level))
125	env user := ""
126	env user_auth_level := 0
127	env rights := var Dictionary empty_dictionary
128
129
130	method env connect
131	arg_rw FtpEnv env
132	if env:data:is_open
133	var Link:Stream data :> env data
134	if ((env:data query "connection_handle") parse (var Int handle)) and (os_socket_wait handle 1 120)=success
135	env:data configure "connect"
136	else
137	env:data error "Timeout on pending FTP connection"
138	if (env:data query "remote_ip_address")<>(env:command query "remote_ip_address")
139	env:data error "Wrong client connected to pending FTP connection"
140	else
141	env:data open env:port in+out+safe+cr+lf
142
143
144	method env allowed path1 write filename -> allow
145	arg FtpEnv env ; arg Str path1 ; arg CBool write ; arg_w Str filename ; arg CBool allow
146	var Data:SiteArea area
147	var Str path := shunt (path1 0 1)="/" path1 env:cwd+path1
148	var Str ext := path
149	ext := ext (ext search_last "/" -1)+1 ext:len
150	ext := ext (ext search_last "." ext:len) ext:len
151	var Int longuest := 0
152	each a env:site:area
153	var Str p := a path
154	if (path 0 p:len)=p
155	var Int l := p len
156	if l>longuest
157	area :> a
158	longuest := l
159	eif l=longuest
160	area :> var Data:SiteArea nonexisting_area
161	if area:root=""
162	filename := env:site:root+(path 1 path:len)
163	else
164	filename := area:root+(path area:path:len path:len)
165	var Str cond := shunt write area:write area:read
166	allow := cond<>"" and (env:rights first cond)<>null or (env:rights first "administrator")<>null
167
168
169	function ftp_read filename from ftp env
170	arg Str filename ; arg Intn from ; arg_rw Stream ftp ; arg_rw FtpEnv env
171	var Str real := filename
172	plugin read_name
173	var Stream file ; file open real in+safe+(shunt from=0 bigcache 0)
174	if file=success
175	if from<>0
176	file configure "seek "+string:from
177	env writeline "150 ready to read file "+file:name ; ftp flush async
178	env connect
179	while not file:atend and env:data<>failure
180	var Address adr ; var Int size
181	file read_available adr size
182	env:data raw_write adr size
183	if file:close=success and env:data:close=success
184	env writeline "226 File "+file:name+" has been red successfully."
185	else
186	env writeline "551 Failed to read from disk."
187	else
188	env writeline "550 Failed to open file "+file:name
189
190
191	function ftp_write filename from ftp env
192	arg Str filename ; arg Intn from ; arg_rw Stream ftp ; arg_rw FtpEnv env
193	var Str real := filename
194	plugin write_name
195	var Stream file ; file open real out+safe+(shunt from=0 bigcache 0)
196	if file=success
197	if from<>0
198	file configure "seek "+string:from
199	env writeline "150 ready to write file "+file:name ; ftp flush async
200	env connect
201	while not env:data:atend
202	var Address adr ; var Int size
203	env:data read_available adr size
204	file raw_write adr size
205	if file:close=success and env:data:close=success
206	env writeline "226 File "+file:name+" has been written successfully."
207	else
208	env writeline "551 Failed to write to disk."
209	else
210	env writeline "550 Failed to open file "+file:name
211
212
213	function ftp_list filename original_name details_level ftp env
214	arg Str filename original_name ; arg Int details_level ; arg_rw Stream ftp ; arg_rw FtpEnv env
215	env writeline "150 "+(repeat 60 "-") ; ftp flush async
216	var Str real := filename
217	var Str f := shunt (original_name 0 1)="/" original_name env:cwd+original_name
218	if f:len>=4 and (f f:len-4 4)="/*.*"
219	real := real 0 real:len-3 ; f := f 0 f:len-3
220	eif f:len>=2 and (f f:len-2 2)="/*"
221	real := real 0 real:len-1 ; f := f 0 f:len-1
222	if f:len=0 or (f f:len-1)<>"/"
223	real += "/" ; f += "/"
224	plugin list_name
225	var Array:FileInfo files := file_list real (shunt details_level>2 extended standard)+relative+directories
226	var Dictionary known ; var CBool computed := false
227	each a env:site:area
228	if (a:path 0 f:len)=f and a:root<>""
229	var Str sub := a:path f:len a:path:len
230	if (sub search_last "/" -2)=sub:len-1
231	if not computed
232	for (var Int i) 0 files:size-1
233	known insert files:i:name true addressof:void
234	computed := true
235	if (known first sub)=null
236	var FileInfo extra := file_query (shunt a:root<>"" a:root env:site:root+(a:path 1 a:path:len)) (shunt details_level>2 extended standard)+directories
237	extra name := sub
238	files += extra
239	if files:size=0 and filename:len<>0 and (filename real:len-1)<>"/"
240	var FileInfo file := file_query filename extended+relative
241	if file=defined
242	file name := file name_without_path
243	files += file
244	plugin list_content
245	env connect
246	for (var Int i) 0 files:size-1
247	if details_level>0
248	var Str l
249	if (env:server:unix_style and details_level<2)
250	l := (shunt files:i:is_directory "d" "-")+"rwxrwxrwx"
251	# var Int mode := files:i:options option "mode" Int
252	# if mode=undefined
253	#   mode := 0
254	# for (var Int j) 8 0 step -1
255	#   l += shunt (mode .and. 2^j)<>0 "xwr":(j%3) "-"
256	l += "   0 any      any  "+(right (string files:i:size) 12 " ")
257	var Int year month day hour minute second ; var Float fraction
258	var DateTime dt := files:i:datetime
259	if dt=undefined
260	dt := datetime
261	dt split year month day hour minute second fraction
262	# var Str d := day_name files:i:datetime:day_of_week
263	# l += " "+upper:(d 0 1)+(d 1 2)
264	l += " "+("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" (month-1)*4 3)
265	l += " "+(right string:day 2 " ")
266	if false
267	l += " "+(right string:hour 2 "0")
268	l += ":"+(right string:minute 2 "0")
269	# l += ":"+(right string:second 2 "0")
270	else
271	l += " "+(right string:year 5 " ")
272	l += " "+(shunt files:i:is_directory (files:i:name 0 files:i:name:len-1) files:i:name)
273	plugin list_unix_file
274	else
275	var Str opt := string files:i:options
276	opt := (shunt opt:len>2 " " "")+(opt 1 opt:len-2)
277	l := (left (string files:i:name) 42 " ")+" "+(right (string files:i:size) 12 " ")+" "+(string files:i:datetime)+opt
278	plugin list_pliant_file
279	env:data writeline l
280	env:log trace "list " l
281	else
282	env:data writeline files:i:name
283	env:log trace "list " files:i:name
284	env:data close
285	env writeline "226 "+(repeat 60 "-")
286
287
288	method server service ftp
289	arg_rw FtpServer server ; arg_rw Stream ftp
290	var FtpEnv env
291	env:log bind ftp_trace
292	env server :> server
293	env command :> ftp
294	env assign_user
295	env:log trace "FTP connection start at " datetime " from " (ftp query "remote_ip_address")
296	ftp writeline "220 Welcome to Pliant FTP server"
297	env:log trace "welcome 220 Welcome to Pliant FTP server"
298	var Str user_name
299	part dialog
300	while not ftp:atend
301	var Str cmd := ftp readline
302	env:log trace "query " cmd
303	if (plugin condition false)
304	plugin action
305	eif (cmd parse word:"USER" any:user_name)
306	plugin command_user
307	env writeline "331 User name okay, need password."
308	eif (cmd parse word:"PASS" any:(var Str password))
309	plugin command_pass
310	var Data:UserSecret u :> user_secret_database:data:user user_name
311	if (plugin login string_md5_hexa_signature:password=u:password_md5)
312	env user := user_name ; env:user_auth_level := 1 ; env assign_user
313	env writeline "230 User logged in."
314	eif user_name="" or user_name="anonymous"
315	env writeline "230 User logged in."
316	else
317	sleep 1
318	env writeline "531 Bad password for "+user_name
319	plugin login
320	eif (cmd parse word:"PORT" (var Int i1) "," (var Int i2) "," (var Int i3) "," (var Int i4) "," (var Int p1) "," (var Int p2))
321	plugin command_port
322	if passive and env:data:is_open
323	env writeline "200 ok"
324	eif active
325	(ftp query "remote_ip_address") parse (var Int j1) "." (var Int j2) "." (var Int j3) "." (var Int j4)
326	if j1=i1 and j2=i2 and j3=i3 and j4=i4
327	env port := "tcp://"+string:i1+"."+string:i2+"."+string:i3+"."+string:i4+"/client/"+(string p1*256+p2)
328	env writeline "200 ok"
329	else
330	env port := ""
331	env writeline "500 Illegal PORT command."
332	else
333	env port := ""
334	env writeline "500 Illegal PORT command."
335	eif passive and (cmd parse word:"PASV")
336	plugin command_passive
337	env:data open "tcp:/server/any" "noautoconnect" in+out+safe+cr+lf
338	(env:data query "local_ip_port") parse (var Int port)
339	env writeline "227 Entering Passive Mode. ("+(replace (ftp query "local_ip_address") "." ",")+","+(string port\256)+","+(string port%256)+")"
340	eif (cmd parse word:"RETR" any:(var Str path))
341	plugin command_retr
342	if (env allowed path false (var Str filename))
343	ftp_read filename 0 ftp env
344	else
345	env writeline "530 Your are not allowed to access that file."
346	eif (cmd parse word:"STOR" any:path)
347	plugin command_stor
348	if (env allowed path true filename)
349	ftp_write filename 0 ftp env
350	else
351	env writeline "530 Your are not allowed to access that file."
352	eif (cmd parse word:"CWD" any:path) or (cmd parse word:"CDUP")
353	plugin command_cwd
354	var Str dir
355	if (cmd parse word:"CDUP")
356	dir := shunt env:cwd="/" "/" env:cwd+"../"
357	else
358	dir := shunt (path 0 1)="/" path env:cwd+path
359	if dir="" or (dir dir:len-1)<>"/"
360	dir += "/"
361	while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail))
362	dir := reverse head+"/"+tail
363	if (env allowed dir false filename)
364	env cwd := dir
365	env writeline "257 [dq]"+env:cwd+"[dq] is the new current directory."
366	else
367	env writeline "530 You are not allowed to access that directory."
368	eif (cmd parse word:"PWD")
369	plugin command_pwd
370	env writeline "257 [dq]"+env:cwd+"[dq] is the current directory."
371	eif (cmd parse word:"MKD" any:path)
372	plugin command_mkd
373	var Str dir := shunt (path 0 1)="/" path env:cwd+path
374	if dir="" or (dir dir:len-1)<>"/"
375	dir += "/"
376	while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail))
377	dir := reverse head+"/"+tail
378	if (env allowed dir true filename)
379	if (file_tree_create filename)=success
380	env writeline "257 "+string:path+" created."
381	else
382	env writeline "550 Could not create the directory."
383	else
384	env writeline "530 Your are not allowed to access that file."
385	eif (cmd parse word:"DELE" any:path)
386	plugin command_dele
387	if (env allowed path true filename)
388	if (file_delete filename)=success
389	env writeline "250 file removed."
390	else
391	env writeline "550 Could not remove the file."
392	else
393	env writeline "530 Your are not allowed to access that file."
394	eif (cmd parse word:"RMD" any:path)
395	plugin command_rmd
396	var Str dir := shunt (path 0 1)="/" path env:cwd+path
397	if dir="" or (dir dir:len-1)<>"/"
398	dir += "/"
399	while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail))
400	dir := reverse head+"/"+tail
401	if (env allowed dir true filename)
402	if (file_delete filename)=success
403	env writeline "250 directory removed."
404	else
405	env writeline "550 Could not remove the directory."
406	else
407	env writeline "530 Your are not allowed to access that directory."
408	eif (cmd parse word:"LIST" any:path)
409	plugin command_list
410	var Int details_level := 1
411	while (path eparse "-" any:(var Str opt) _ any:(var Str path2)) or { path2 := "" ; path eparse "-" any:(var Str opt) }
412	if opt="pliant"
413	details_level := max details_level 2
414	if opt="extended"
415	details_level := max details_level 3
416	path := path2
417	if (env allowed path false filename)
418	ftp_list filename path details_level ftp env
419	else
420	env writeline "530 You are not allowed to access that directory."
421	eif (cmd parse word:"NLST" any:path)
422	plugin command_nlst
423	if (env allowed path false filename)
424	ftp_list filename path 0 ftp env
425	else
426	env writeline "530 You are not allowed to access that directory."
427	eif (cmd parse word:"MDTM" any:path)
428	plugin command_mdtm
429	if (env allowed path false filename)
430	var FileInfo info := file_query filename standard
431	if info=failure
432	env writeline "550 Failed to open file "+filename
433	else
434	info:datetime split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction)
435	env writeline "200 "+(right string:year 4 "0")+(right string:month 2 "0")+(right string:day 2 "0")+(right string:hour 2 "0")+(right string:minute 2 "0")+(right string:second 2 "0")
436	else
437	env writeline "530 Your are not allowed to access that file."
438	eif (cmd parse word:"SIZE" any:path)
439	plugin command_size
440	if (env allowed path false filename)
441	var FileInfo info := file_query filename standard
442	if info=failure
443	env writeline "550 Failed to open file "+filename
444	else
445	env writeline "200 "+(string info:size)
446	else
447	env writeline "530 Your are not allowed to access that file."
448	eif (cmd parse word:"SYST")
449	plugin command_syst
450	env writeline "200 Pliant FTP server"+(shunt server:send_software_release_number " release "+string:pliant_release_number "")+(shunt server:unix_style " (Unix style)" "")
451	eif (cmd parse word:"TYPE" any:(var Str mode))
452	plugin command_type
453	if mode="I"
454	env writeline "200 Type set to Image."
455	eif mode="A"
456	env writeline "200 Ascii ignored !"
457	else
458	env writeline "504 Only Image type is supported, not "+mode+"."
459	eif (cmd parse word:"MODE" any:mode)
460	plugin command_mode
461	if mode="S"
462	env writeline "200 Mode set to Stream."
463	else
464	env writeline "504 Only Stream mode is supported."
465	eif (cmd parse word:"QUIT")
466	plugin command_quit
467	env writeline "221 Good bye."
468	return
469	else
470	plugin unknown_command
471	env writeline "502 Command not implemented."
472	env:log trace "FTP connection stop at " datetime " from " (ftp query "remote_ip_address")
473
474
475	define_tcp_server FtpServer ftp_server
476	export ftp_server
477