source: trunk/Packages/synapse/source/demo/ftpserv/ftpthrd.pas

Last change on this file was 2, checked in by chronos, 13 years ago
  • Přidáno: Základní kostra projektu.
  • Přidáno: Knihovna synapse.
File size: 9.6 KB
Line 
1unit FtpThrd;
2
3{$IFDEF FPC}
4 {$mode delphi}
5{$endif}
6
7interface
8
9uses
10{$IFDEF LINUX}
11 Libc,
12{$ELSE}
13 Windows,
14{$ENDIF}
15 Classes, SysUtils, blcksock, synsock, synautil, filectrl;
16
17type
18 TFtpServerThread = class(TThread)
19 private
20 clients: TSocket;
21 FDataIP, FDataPort: string;
22 protected
23 procedure Execute; override;
24 procedure send(const sock: TTcpBlocksocket; value: string);
25 procedure ParseRemote(Value: string);
26 function buildname(dir, value: string): string;
27 function buildrealname(value: string): string;
28 function buildlist(value: string): string;
29 public
30 constructor Create(sock: TSocket);
31 end;
32
33implementation
34
35const
36 timeout = 60000;
37 MyMonthNames: array[1..12] of AnsiString =
38 ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
39 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
40
41
42{==============================================================================}
43{ TFtpServerThread }
44
45constructor TFtpServerThread.create(sock: TSocket);
46begin
47 inherited create(false);
48 FreeOnTerminate := true;
49 clients := sock;
50// Priority := tpNormal;
51end;
52
53procedure TFtpServerThread.send(const sock: TTcpBlocksocket; value: string);
54begin
55 sock.SendString(value + CRLF);
56end;
57
58procedure TFtpServerThread.ParseRemote(Value: string);
59var
60 n: integer;
61 nb, ne: integer;
62 s: string;
63 x: integer;
64begin
65 Value := trim(Value);
66 nb := Pos('(',Value);
67 ne := Pos(')',Value);
68 if (nb = 0) or (ne = 0) then
69 begin
70 nb:=RPos(' ',Value);
71 s:=Copy(Value, nb + 1, Length(Value) - nb);
72 end
73 else
74 begin
75 s:=Copy(Value,nb+1,ne-nb-1);
76 end;
77 for n := 1 to 4 do
78 if n = 1 then
79 FDataIP := Fetch(s, ',')
80 else
81 FDataIP := FDataIP + '.' + Fetch(s, ',');
82 x := StrToIntDef(Fetch(s, ','), 0) * 256;
83 x := x + StrToIntDef(Fetch(s, ','), 0);
84 FDataPort := IntToStr(x);
85end;
86
87function TFtpServerThread.buildname(dir, value: string): string;
88begin
89 if value = '' then
90 begin
91 result := dir;
92 exit;
93 end;
94 if value[1] = '/' then
95 result := value
96 else
97 if (dir <> '') and (dir[length(dir)] = '/') then
98 Result := dir + value
99 else
100 Result := dir + '/' + value;
101end;
102
103function TFtpServerThread.buildrealname(value: string): string;
104begin
105 value := replacestring(value, '..', '.');
106 value := replacestring(value, '/', '\');
107 result := '.\data' + value;
108end;
109
110function fdate(value: integer): string;
111var
112 st: tdatetime;
113 wYear, wMonth, wDay: word;
114begin
115 st := filedatetodatetime(value);
116 DecodeDate(st, wYear, wMonth, wDay);
117 Result:= Format('%d %s %d', [wday, MyMonthNames[wMonth], wyear]);
118end;
119
120function TFtpServerThread.buildlist(value: string): string;
121var
122 SearchRec: TSearchRec;
123 r: integer;
124 s: string;
125begin
126 result := '';
127 if value = '' then
128 exit;
129 if value[length(value)] <> '\' then
130 value := value + '\';
131 R := FindFirst(value + '*.*', faanyfile, SearchRec);
132 while r = 0 do
133 begin
134 if ((searchrec.Attr and faHidden) = 0)
135 and ((searchrec.Attr and faSysFile) = 0)
136 and ((searchrec.Attr and faVolumeID) = 0) then
137 begin
138 s := '';
139 if (searchrec.Attr and faDirectory) > 0 then
140 begin
141 if (searchrec.Name <> '.') and (searchrec.Name <> '..') then
142 begin
143 s := s + 'drwxrwxrwx 1 root root 1 ';
144 s := s + fdate(searchrec.time) + ' ';
145 s := s + searchrec.name;
146 end;
147 end
148 else
149 begin
150 s := s + '-rwxrwxrwx 1 root other ';
151 s := s + inttostr(searchrec.Size) + ' ';
152 s := s + fdate(searchrec.time) + ' ';
153 s := s + searchrec.name;
154 end;
155 if s <> '' then
156 Result := Result + s + CRLF;
157 end;
158 r := findnext(SearchRec);
159 end;
160 Findclose(searchrec);
161end;
162
163procedure TFtpServerThread.Execute;
164var
165 sock, dsock: TTCPBlockSocket;
166 s, t: string;
167 authdone: boolean;
168 user: string;
169 cmd, par: string;
170 pwd: string;
171 st: TFileStream;
172begin
173 sock := TTCPBlockSocket.Create;
174 dsock := TTCPBlockSocket.Create;
175 try
176 sock.Socket := clients;
177 send(sock, '220 welcome ' + sock.GetRemoteSinIP + '!');
178 authdone := false;
179 user := '';
180 repeat
181 s := sock.RecvString(timeout);
182 cmd := uppercase(separateleft(s, ' '));
183 par := separateright(s, ' ');
184 if sock.lasterror <> 0 then
185 exit;
186 if terminated then
187 exit;
188 if cmd = 'USER' then
189 begin
190 user := par;
191 send(sock, '331 Please specify the password.');
192 continue;
193 end;
194 if cmd = 'PASS' then
195 begin
196 //user verification...
197 if ((user = 'username') and (par = 'password'))
198 or (user = 'anonymous') then
199 begin
200 send(sock, '230 Login successful.');
201 authdone := true;
202 continue;
203 end;
204 end;
205 send(sock, '500 Syntax error, command unrecognized.');
206 until authdone;
207
208 pwd := '/';
209 repeat
210 s := sock.RecvString(timeout);
211 cmd := uppercase(separateleft(s, ' '));
212 par := separateright(s, ' ');
213 if par = s then
214 par := '';
215 if sock.lasterror <> 0 then
216 exit;
217 if terminated then
218 exit;
219 if cmd = 'QUIT' then
220 begin
221 send(sock, '221 Service closing control connection.');
222 break;
223 end;
224 if cmd = 'NOOP' then
225 begin
226 send(sock, '200 tjadydadydadydaaaaa!');
227 continue;
228 end;
229 if cmd = 'PWD' then
230 begin
231 send(sock, '257 ' + Quotestr(pwd, '"'));
232 continue;
233 end;
234 if cmd = 'CWD' then
235 begin
236 t := unquotestr(par, '"');
237 t := buildname(pwd, t);
238 if directoryexists(Buildrealname(t)) then
239 begin
240 pwd := t;
241 send(sock, '250 OK ' + t);
242 end
243 else
244 send(sock, '550 Requested action not taken.');
245 continue;
246 end;
247 if cmd = 'MKD' then
248 begin
249 t := unquotestr(par, '"');
250 t := buildname(pwd, t);
251 if CreateDir(Buildrealname(t)) then
252 begin
253 pwd := t;
254 send(sock, '257 "' + t + '" directory created');
255 end
256 else
257 send(sock, '521 "' + t + '" Requested action not taken.');
258 continue;
259 end;
260 if cmd = 'CDUP' then
261 begin
262 pwd := '/';
263 send(sock, '250 OK');
264 continue;
265 end;
266 if (cmd = 'TYPE')
267 or (cmd = 'ALLO')
268 or (cmd = 'STRU')
269 or (cmd = 'MODE') then
270 begin
271 send(sock, '200 OK');
272 continue;
273 end;
274 if cmd = 'PORT' then
275 begin
276 Parseremote(par);
277 send(sock, '200 OK');
278 continue;
279 end;
280 if cmd = 'LIST' then
281 begin
282 t := unquotestr(par, '"');
283 t := buildname(pwd, t);
284 dsock.CloseSocket;
285 dsock.Connect(Fdataip, Fdataport);
286 if dsock.LastError <> 0 then
287 send(sock, '425 Can''t open data connection.')
288 else
289 begin
290 send(sock, '150 OK ' + t);
291 dsock.SendString(buildlist(buildrealname(t)));
292 send(sock, '226 OK ' + t);
293 end;
294 dsock.CloseSocket;
295 continue;
296 end;
297 if cmd = 'RETR' then
298 begin
299 t := unquotestr(par, '"');
300 t := buildname(pwd, t);
301 if fileexists(buildrealname(t)) then
302 begin
303 dsock.CloseSocket;
304 dsock.Connect(Fdataip, Fdataport);
305 dsock.SetLinger(true, 10000);
306 if dsock.LastError <> 0 then
307 send(sock, '425 Can''t open data connection.')
308 else
309 begin
310 send(sock, '150 OK ' + t);
311 try
312 st := TFileStream.Create(buildrealname(t), fmOpenRead or fmShareDenyWrite);
313 try
314 dsock.SendStreamRaw(st);
315 finally
316 st.free;
317 end;
318 send(sock, '226 OK ' + t);
319 except
320 on exception do
321 send(sock, '451 Requested action aborted: local error in processing.');
322 end;
323 end;
324 dsock.CloseSocket;
325 end
326 else
327 send(sock, '550 File unavailable. ' + t);
328 continue;
329 end;
330 if cmd = 'STOR' then
331 begin
332 t := unquotestr(par, '"');
333 t := buildname(pwd, t);
334 if directoryexists(extractfiledir(buildrealname(t))) then
335 begin
336 dsock.CloseSocket;
337 dsock.Connect(Fdataip, Fdataport);
338 dsock.SetLinger(true, 10000);
339 if dsock.LastError <> 0 then
340 send(sock, '425 Can''t open data connection.')
341 else
342 begin
343 send(sock, '150 OK ' + t);
344 try
345 st := TFileStream.Create(buildrealname(t), fmCreate or fmShareDenyWrite);
346 try
347 dsock.RecvStreamRaw(st, timeout);
348 finally
349 st.free;
350 end;
351 send(sock, '226 OK ' + t);
352 except
353 on exception do
354 send(sock, '451 Requested action aborted: local error in processing.');
355 end;
356 end;
357 dsock.CloseSocket;
358 end
359 else
360 send(sock, '553 Directory not exists. ' + t);
361 continue;
362 end;
363 send(sock, '500 Syntax error, command unrecognized.');
364 until false;
365
366 finally
367 dsock.free;
368 sock.free;
369 end;
370end;
371
372{==============================================================================}
373end.
Note: See TracBrowser for help on using the repository browser.