-
Notifications
You must be signed in to change notification settings - Fork 125
/
ftpServerType.ml
448 lines (395 loc) · 17.4 KB
/
ftpServerType.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA 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 Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* ftpServerType.ml:
* Support code for ftpServerCore.proto.
* TODO:
* 1) Reset cwd when connection closed.
* 2) Arrange for log messages.
* 3) Handle missing files.
*)
let protocol = NetAddr.mk_protocol "FTP"
let (<|) f a = f a
let (|>) a f = f a
let ( @* ) g f x = g(f(x))
module List = Base.List
module String = Base.String
type form_code = N | T | C
let str_of_form_code fc = match fc with N -> "N" | T -> "T" | C -> "C"
type type_code =
A of form_code option
| E of form_code option
| I
| L of int
let str_of_type_code tc =
match tc with
A (Some fc) -> "A "^(str_of_form_code fc)
| A None -> "A"
| E (Some fc) -> "E "^(str_of_form_code fc)
| E None -> "E"
| I -> "I"
| L num -> Printf.sprintf "L %d" num
type structure_code = F | R | P
let str_of_structure_code sc = match sc with F -> "F" | R -> "R" | P -> "P"
type transfer_mode = S | B | C
let str_of_transfer_mode tm = match tm with S -> "S" | B -> "B" | C -> "C"
type web_info = unit
type state = {
version: string; (** ftpServer version string *)
hello_message: string list; (** Message for new connection *)
goodbye_message: string; (** End of connection message *)
is_admin: bool; (** admin mode *)
user: string option; (** current user *)
data_port_spec: Network.port_spec; (** current data channel port spec *)
data_secure_mode: Network.secure_mode; (** current data channel secure mode *)
passive : bool; (** passive mode *)
pasv_port_min:int; (** minimum port for passive connection *)
pasv_port_max:int; (** maximum port for passive connection *)
pasv_port_spec: Network.port_spec option ref; (** passive mode port spec *)
pasv_secure_mode: Network.secure_mode option ref; (** passive mode secure mode *)
pasv_port_conn: Scheduler.connection_info option ref; (** the passive port connection *)
local_ip_num:string; (** string of server's IP number *)
data_conn: Scheduler.connection_info option; (** [Some] if currently open *)
data_blocksize: int; (** blocksize for transfers *)
data_type: type_code; (** FTP data transfer type *)
binary: bool; (** transfer binary mode flag *)
start_position: int; (** marker for REST verb *)
structure_code: structure_code; (** FTP data structure *)
transfer_mode: transfer_mode; (** FTP transfer mode *)
folder: Folder.folder; (** restricted filespace, see folder.mli *)
default_folder: string; (** starting folder for new connections *)
rename_string: string option; (** from path for RNFR verb *)
timeout: Time.t; (** global connection timeout *)
drop_privilege: bool;
ssl_cert: string;
ssl_key: string;
ssl_pass: string;
}
(** FTP servers seem to think they have the root dir.
We don't implement this for now but we might want to think
about a virtual root dir for our server.
*)
let mk_rel (*state*)_ filename =
(*if not (Filename.is_relative filename) then Filename.concat state.default_folder filename else*) filename
(** Predicate for valid folder. *)
let valid_folder state dir = Folder.valid_folder state.folder (mk_rel state dir)
(** Check if folder is writable, dir or file *)
let writable_folder state dir = Folder.writable_folder state.folder (mk_rel state dir)
(** Change the working dir {b in [folder.state] not the OS working dir}. *)
let cwd state dir =
try
Folder.chfolder state.folder (mk_rel state dir);
prerr_endline (Printf.sprintf "cwd: %s" dir);
true
with Folder.Folder_error _ -> false
(** Return working dir {b from [folder.state] not the OS working dir}. *)
let pwd state = (*String.remove_prefix_if_possible state.default_folder*) (Folder.current_folder state.folder)
let rename_folder state from_name to_name =
prerr_endline (Printf.sprintf "rename_folder: %s as %s" from_name to_name);
Folder.rename_folder state.folder (mk_rel state from_name) (mk_rel state to_name)
let delete_folder state name =
prerr_endline (Printf.sprintf "delete_folder: %s" name);
Folder.delete_folder state.folder (mk_rel state name)
let create_directory state name =
prerr_endline (Printf.sprintf "create_directory: %s" name);
Folder.create_directory state.folder (mk_rel state name)
let delete_directory state name =
prerr_endline (Printf.sprintf "delete_directory: %s" name);
Folder.delete_directory state.folder (mk_rel state name)
(** set_port:
* We turn the ftp stuff into an inet_addr and we also
* have to remember to do the arithmetic on the port number.
* All values are range checked, the inet_addr is done by the
* Unix lib parser but we need to do the port manually.
*)
let chk255 i = i < 0 || i > 255
let get255 str = let i = int_of_string str in if chk255 i then raise (Failure "get255") else i
let get_port_number p1 p2 = (get255 p1) * 256 + (get255 p2)
let set_port state str =
try
match Str.split (Str.regexp ",") str with
[h1;h2;h3;h4;p1;p2] ->
let addr = Unix.inet_addr_of_string (Printf.sprintf "%s.%s.%s.%s" h1 h2 h3 h4) in
let port = get_port_number p1 p2 in
let port_spec = Network.make_port_spec ~protocol addr port in
let state' = {state with data_port_spec=port_spec} in
prerr_endline ("setting port to "^(Printf.sprintf "%s:%d" (Unix.string_of_inet_addr addr) port));
(state',true)
| _ -> (state,false)
with Failure _ -> (state,false)
(** set_type:
* Initially, we only have ASCII non-printable.
* We need three outcomes, success, failure and not implemented.
* We would also like some slight flexibility in the format
* for example, we might allow "A N". Hence the rather silly
* regexp which is guaranteed to match even if there is nothing
* in the optional part. We also want to return the message
* from here but we can't "send" an ocaml value in the DSL.
* Instead, we just encode the return value and get the required
* behaviour by constructing if..then trees in the DSL.
* What we would really like is a "match" construct in the DSL.
*)
let get_type str =
if Str.string_match (Str.regexp "[ ]*\\([AEIL]\\)[ ]*\\([^ ]*\\)[ ]*") str 0
then
match (Str.matched_group 1 str,Str.matched_group 2 str) with
("A","N") -> (false, A (Some N))
| ("A","T") -> raise (Failure "504")
| ("A","C") -> raise (Failure "504")
| ("A","") -> (false, A None)
| ("E","N") -> raise (Failure "504")
| ("E","T") -> raise (Failure "504")
| ("E","C") -> raise (Failure "504")
| ("E","") -> raise (Failure "504")
| ("I","") -> (true, I)
| ("L",numstr) ->
let num = int_of_string numstr in
if num >= 0 && num <= 255
then
if num = 8
then (true, L 8)
else raise (Failure "504")
else raise (Failure "501")
| _ -> raise (Failure "501")
else raise (Failure "501")
let set_type state str =
try
let bin, type_code = get_type str in
let state = {state with data_type=type_code; binary=bin} in
prerr_endline ("Setting TYPE to "^str_of_type_code type_code);
(state,"200")
with
| Failure "504" -> (state,"504")
| Failure _ -> (state,"501")
(** Return a string representing the type in the 150 reply *)
let get_binary_mode state =
match state.data_type with
| A _ -> "ASCII"
| E _ -> "EBCDIC"
| I | L 8 -> "BINARY"
| _ -> "UNKOWN"
(** set_structure_code:
* Same model as above except there are fewer options.
*)
let set_structure_code state str =
try
if Str.string_match (Str.regexp "[ ]*\\([FRP]\\)") str 0
then
let sc =
match Str.matched_group 1 str with
"F" -> F
| "R" -> R
| "P" -> raise (Failure "504")
| _ -> raise (Failure "504") in
let state' = {state with structure_code=sc} in
prerr_endline ("Setting STRU to "^str_of_structure_code sc);
(state',"200")
else raise (Failure "501")
with
| Failure "504" -> (state,"504")
| Failure _ -> (state,"501")
(** set_transfer_mode:
* Same again.
*)
let set_transfer_mode state str =
try
if Str.string_match (Str.regexp "[ ]*\\([SBC]\\)") str 0
then
let tm =
match Str.matched_group 1 str with
"S" -> S
| "B" -> raise (Failure "504")
| "C" -> raise (Failure "504")
| _ -> raise (Failure "504") in
let state' = {state with transfer_mode=tm} in
prerr_endline ("Setting MODE to "^str_of_transfer_mode tm);
(state',"200")
else raise (Failure "501")
with
| Failure "504" -> (state,"504")
| Failure _ -> (state,"501")
(** cr2crlf:
In ASCII mode we need to ensure that all \n characters are turned into \n\r.
This method creates a string of twice the size and then transforms the original
string into that and then truncates it. This involves a lot of copying so it
would be better to do this in a stream of some kind.
*)
let cr2crlf str =
let len = String.length str in
let s2 = String.create (len * 2) in
let j = ref 0 in
for i = 0 to len - 1 do
if str.[i] = '\n'
then (s2.[!j] <- '\r'; s2.[(!j)+1] <- '\n'; j := !j + 2)
else (s2.[!j] <- str.[i]; j := !j + 1)
done;
String.sub s2 0 (!j);;
(** crlf2cr:
In fact, we also need to to the reverse...
Again, we are all {i in situ} so it's pretty inefficient.
*)
let crlf2cr str =
let len = String.length str in
let s2 = String.create len in
let i,j = ref 0,ref 0 in
while (!i) <= len - 2 do
if (str.[(!i)] = '\n' && str.[(!i)+1] = '\r') || (str.[(!i)] = '\r' && str.[(!i)+1] = '\n')
then (s2.[!j] <- '\n'; i := !i + 2)
else (s2.[!j] <- str.[(!i)]; i := !i + 1);
j := !j + 1
done;
if (!i) <= len - 1 then begin s2.[!j] <- str.[(!i)]; j := !j + 1 end;
String.sub s2 0 (!j);;
(** set_folder_start:
Try to seek to the given position in the given file desc.
Any failure, close file and return None.
*)
let set_folder_start state fd_opt =
if state.start_position > 0
then
match fd_opt with
Some fd ->
(try
let pos = Folder.lseek fd state.start_position in
if pos = state.start_position
then
(prerr_endline (Printf.sprintf "set_folder_start: pos=%d" pos);
Some fd)
else (Folder.closefile fd; None)
with Unix.Unix_error _ -> (Folder.closefile fd; None))
| None -> None
else fd_opt
(** open_folder_read:
safe replacement for open_file in read mode, check if in valid directory
special processing required for start_position
*)
let open_folder_read state filename =
prerr_endline (Printf.sprintf "open_folder_read: %s" filename);
set_folder_start state (Folder.openfileread state.folder filename)
(** open_folder_write: safe replacement for open_filein write mode, check if in valid directory *)
let open_folder_write state filename =
prerr_endline (Printf.sprintf "open_folder_write: %s" filename);
Folder.openfilewrite state.folder filename
(** open_folder_append: safe replacement for open_filein append mode, check if in valid directory *)
let open_folder_append state filename =
prerr_endline (Printf.sprintf "open_folder_append: %s" filename);
Folder.openfileappend state.folder filename
(** read_folder:
just a write-through to the OS read function except that we do the crlf
conversion on the data.
*)
let read_folder state fd cnt =
if state.binary
then Some (Folder.read fd cnt)
else Some (cr2crlf <| Folder.read fd cnt)
(** write_folder:
This time we need to extract the data from a buffer provided by Scheduler.read and
perform the reverse transformation on crlf.
*)
let write_folder state fd (buff:string) (* (buff:FBuffer.t) *) size =
(*let str = FBuffer.sub buff 0 size in*)
let str = String.sub buff 0 size in
let str = if state.binary then crlf2cr str else str in
Folder.write fd str (String.length str)
(** close_folder: another write-through *)
let close_folder fd =
prerr_endline (Printf.sprintf "close_folder");
Folder.closefile fd
(** get_unique_filename: create a unique filename for current directory *)
let get_unique_filename temp pre post = Filename.temp_file ?temp_dir:(Some temp) pre post
(** Return list of files in ascii format (ie. crlf terminated) *)
let plain_file (*folder*)_ filenames = filenames
let ls_file folder filenames = Folder.ls_files folder filenames
let list folder dir list_fn =
prerr_endline (Printf.sprintf "list: dir=%s" dir);
match Folder.list folder dir with
Some files ->
Array.sort String.compare files;
(Array.fold_right (fun ss s -> ss^"\r\n"^s) (list_fn folder files) "", true)
| None -> ("",false)
(** get_passive_port:
Return a suitable port_spec for using as the passive port.
Since we can't close a listener, we have to reuse the existing one, if found.
So we store the port_spec in a reference.
This may cause a problem for multiple connections.
We also return the string definition for the PORT reply.
For now, the IP number is simply set by the caller.
*)
let get_passive_port state (*sched*)_ =
try
let state, addr_str, port, port_spec_opt, sec_mode_opt =
match !(state.pasv_port_spec) with
Some port_spec ->
prerr_endline (Printf.sprintf "get_passive_port: using old port=%d" port_spec.Network.port);
state, Unix.string_of_inet_addr port_spec.Network.addr, port_spec.Network.port, None, None
| None ->
let port = Random.int (state.pasv_port_max - state.pasv_port_min) + state.pasv_port_min in
let addr = Unix.inet_addr_of_string state.local_ip_num in
let port_spec = Network.make_port_spec ~protocol addr port in
state.pasv_port_spec := Some port_spec;
state.pasv_secure_mode := Some Network.Unsecured;
prerr_endline (Printf.sprintf "get_passive_port: port=%d" port);
prerr_endline (Printf.sprintf "get_passive_port: addr=%s" (Unix.string_of_inet_addr addr));
state, state.local_ip_num, port, Some port_spec, Some Network.Unsecured
in
match Str.split (Str.regexp_string ".") addr_str with
[h1;h2;h3;h4] ->
let str = Printf.sprintf "%d,%d,%d,%d,%d,%d" (get255 h1) (get255 h2) (get255 h3) (get255 h4)
((port / 256) land 0xff) (port land 0xff) in
prerr_endline (Printf.sprintf "get_passive_port: str=%s" str);
state, Some (str, port_spec_opt, sec_mode_opt)
| _ ->
prerr_endline (Printf.sprintf "get_passive_port: failed ipnum=%s" state.local_ip_num);
state, None
with exn ->
prerr_endline (Printf.sprintf "get_passive_port: exn=%s" (Printexc.to_string exn));
state, None
let all_commands =
[("ACCT",true); ("ALLO",true); ("APPE",true); ("CDUP",true); ("CWD ",true); ("DELE",true);
("EPRT",false); ("EPSV",false); ("FEAT",false); ("HELP",true); ("LIST",true); ("MDTM",false);
("MKD ",true); ("MODE",true); ("NLST",true); ("NOOP",true); ("OPTS",false); ("PASS",true);
("PASV",true); ("PORT",true); ("PWD ",true); ("QUIT",true); ("REIN",false); ("REST",false);
("RETR",true); ("RMD ",true); ("RNFR",true); ("RNTO",true); ("SITE",false); ("SIZE",true);
("SMNT",false); ("STAT",true); ("STOR",true); ("STOU",true); ("STRU",true); ("SYST",true);
("TYPE",true); ("USER",true); ("XCUP",false); ("XCWD",false); ("XMKD",false); ("XPWD",false);
("XRMD",false)]
let recognized_commands brk =
(snd <| List.fold_left (fun (i,s) (nm,rc) ->
if rc
then (i+1,s^" "^nm^(if i mod brk = (brk-1) then "\r\n" else ""))
else (i,s)) (0,"") all_commands)^"\r\n"
let server_status state conn =
Printf.sprintf " Connected to %s\n\
%s\n\
TYPE: %s\n\
STRU: %s\n\
MODE: %s\n\
Session timeout is %.0f seconds\n\
MLstate ftpServer version %s\n\
"
(NetAddr.to_string conn.Scheduler.addr)
(match state.user with Some user -> "Logged in as "^user | None -> "Not logged in")
(str_of_type_code state.data_type)
(str_of_structure_code state.structure_code)
(str_of_transfer_mode state.transfer_mode)
(Time.in_seconds state.timeout)
state.version
let get_hello_message state = (List.fold_left (fun ss s -> ss^"220-"^s^"\r\n") "" state.hello_message)^"220 \r\n"
let set_start_position state str =
try
let pos = int_of_string str in
if pos > 0
then ({state with start_position = pos },string_of_int pos)
else ({state with start_position = 0 },"0")
with Failure "int_of_string" -> ({state with start_position = 0 },"0")
(* End of file: ftpServerType.ml *)