source: trunk/Packages/synapse/source/lib/ftptsend.pas

Last change on this file was 2, checked in by chronos, 12 years ago
  • Přidáno: Základní kostra projektu.
  • Přidáno: Knihovna synapse.
File size: 12.2 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 001.001.001 |
3|==============================================================================|
4| Content: Trivial FTP (TFTP) client and server |
5|==============================================================================|
6| Copyright (c)1999-2010, Lukas Gebauer |
7| All rights reserved. |
8| |
9| Redistribution and use in source and binary forms, with or without |
10| modification, are permitted provided that the following conditions are met: |
11| |
12| Redistributions of source code must retain the above copyright notice, this |
13| list of conditions and the following disclaimer. |
14| |
15| Redistributions in binary form must reproduce the above copyright notice, |
16| this list of conditions and the following disclaimer in the documentation |
17| and/or other materials provided with the distribution. |
18| |
19| Neither the name of Lukas Gebauer nor the names of its contributors may |
20| be used to endorse or promote products derived from this software without |
21| specific prior written permission. |
22| |
23| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33| DAMAGE. |
34|==============================================================================|
35| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
37| All Rights Reserved. |
38|==============================================================================|
39| Contributor(s): |
40|==============================================================================|
41| History: see HISTORY.HTM from distribution package |
42| (Found at URL: http://www.ararat.cz/synapse/) |
43|==============================================================================}
44
45{: @abstract(TFTP client and server protocol)
46
47Used RFC: RFC-1350
48}
49
50{$IFDEF FPC}
51 {$MODE DELPHI}
52{$ENDIF}
53{$Q-}
54{$H+}
55
56{$IFDEF UNICODE}
57 {$WARN IMPLICIT_STRING_CAST OFF}
58 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
59{$ENDIF}
60
61unit ftptsend;
62
63interface
64
65uses
66 SysUtils, Classes,
67 blcksock, synautil;
68
69const
70 cTFTPProtocol = '69';
71
72 cTFTP_RRQ = word(1);
73 cTFTP_WRQ = word(2);
74 cTFTP_DTA = word(3);
75 cTFTP_ACK = word(4);
76 cTFTP_ERR = word(5);
77
78type
79 {:@abstract(Implementation of TFTP client and server)
80 Note: Are you missing properties for specify server address and port? Look to
81 parent @link(TSynaClient) too!}
82 TTFTPSend = class(TSynaClient)
83 private
84 FSock: TUDPBlockSocket;
85 FErrorCode: integer;
86 FErrorString: string;
87 FData: TMemoryStream;
88 FRequestIP: string;
89 FRequestPort: string;
90 function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
91 function RecvPacket(Serial: word; var Value: string): Boolean;
92 public
93 constructor Create;
94 destructor Destroy; override;
95
96 {:Upload @link(data) as file to TFTP server.}
97 function SendFile(const Filename: string): Boolean;
98
99 {:Download file from TFTP server to @link(data).}
100 function RecvFile(const Filename: string): Boolean;
101
102 {:Acts as TFTP server and wait for client request. When some request
103 incoming within Timeout, result is @true and parametres is filled with
104 information from request. You must handle this request, validate it, and
105 call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
106 to TFTP Client.}
107 function WaitForRequest(var Req: word; var filename: string): Boolean;
108
109 {:send error to TFTP client, when you acts as TFTP server.}
110 procedure ReplyError(Error: word; Description: string);
111
112 {:Accept uploaded file from TFTP client to @link(data), when you acts as
113 TFTP server.}
114 function ReplyRecv: Boolean;
115
116 {:Accept download request file from TFTP client and send content of
117 @link(data), when you acts as TFTP server.}
118 function ReplySend: Boolean;
119 published
120 {:Code of TFTP error.}
121 property ErrorCode: integer read FErrorCode;
122
123 {:Human readable decription of TFTP error. (if is sended by remote side)}
124 property ErrorString: string read FErrorString;
125
126 {:MemoryStream with datas for sending or receiving}
127 property Data: TMemoryStream read FData;
128
129 {:Address of TFTP remote side.}
130 property RequestIP: string read FRequestIP write FRequestIP;
131
132 {:Port of TFTP remote side.}
133 property RequestPort: string read FRequestPort write FRequestPort;
134 end;
135
136implementation
137
138constructor TTFTPSend.Create;
139begin
140 inherited Create;
141 FSock := TUDPBlockSocket.Create;
142 FSock.Owner := self;
143 FTargetPort := cTFTPProtocol;
144 FData := TMemoryStream.Create;
145 FErrorCode := 0;
146 FErrorString := '';
147end;
148
149destructor TTFTPSend.Destroy;
150begin
151 FSock.Free;
152 FData.Free;
153 inherited Destroy;
154end;
155
156function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
157var
158 s, sh: string;
159begin
160 FErrorCode := 0;
161 FErrorString := '';
162 Result := false;
163 if Cmd <> 2 then
164 s := CodeInt(Cmd) + CodeInt(Serial) + Value
165 else
166 s := CodeInt(Cmd) + Value;
167 FSock.SendString(s);
168 s := FSock.RecvPacket(FTimeout);
169 if FSock.LastError = 0 then
170 if length(s) >= 4 then
171 begin
172 sh := CodeInt(4) + CodeInt(Serial);
173 if Pos(sh, s) = 1 then
174 Result := True
175 else
176 if s[1] = #5 then
177 begin
178 FErrorCode := DecodeInt(s, 3);
179 Delete(s, 1, 4);
180 FErrorString := SeparateLeft(s, #0);
181 end;
182 end;
183end;
184
185function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
186var
187 s: string;
188 ser: word;
189begin
190 FErrorCode := 0;
191 FErrorString := '';
192 Result := False;
193 Value := '';
194 s := FSock.RecvPacket(FTimeout);
195 if FSock.LastError = 0 then
196 if length(s) >= 4 then
197 if DecodeInt(s, 1) = 3 then
198 begin
199 ser := DecodeInt(s, 3);
200 if ser = Serial then
201 begin
202 Delete(s, 1, 4);
203 Value := s;
204 S := CodeInt(4) + CodeInt(ser);
205 FSock.SendString(s);
206 Result := FSock.LastError = 0;
207 end
208 else
209 begin
210 S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
211 FSock.SendString(s);
212 end;
213 end;
214 if DecodeInt(s, 1) = 5 then
215 begin
216 FErrorCode := DecodeInt(s, 3);
217 Delete(s, 1, 4);
218 FErrorString := SeparateLeft(s, #0);
219 end;
220end;
221
222function TTFTPSend.SendFile(const Filename: string): Boolean;
223var
224 s: string;
225 ser: word;
226 n, n1, n2: integer;
227begin
228 Result := False;
229 FErrorCode := 0;
230 FErrorString := '';
231 FSock.CloseSocket;
232 FSock.Connect(FTargetHost, FTargetPort);
233 try
234 if FSock.LastError = 0 then
235 begin
236 s := Filename + #0 + 'octet' + #0;
237 if not Sendpacket(2, 0, s) then
238 Exit;
239 ser := 1;
240 FData.Position := 0;
241 n1 := FData.Size div 512;
242 n2 := FData.Size mod 512;
243 for n := 1 to n1 do
244 begin
245 s := ReadStrFromStream(FData, 512);
246// SetLength(s, 512);
247// FData.Read(pointer(s)^, 512);
248 if not Sendpacket(3, ser, s) then
249 Exit;
250 inc(ser);
251 end;
252 s := ReadStrFromStream(FData, n2);
253// SetLength(s, n2);
254// FData.Read(pointer(s)^, n2);
255 if not Sendpacket(3, ser, s) then
256 Exit;
257 Result := True;
258 end;
259 finally
260 FSock.CloseSocket;
261 end;
262end;
263
264function TTFTPSend.RecvFile(const Filename: string): Boolean;
265var
266 s: string;
267 ser: word;
268begin
269 Result := False;
270 FErrorCode := 0;
271 FErrorString := '';
272 FSock.CloseSocket;
273 FSock.Connect(FTargetHost, FTargetPort);
274 try
275 if FSock.LastError = 0 then
276 begin
277 s := CodeInt(1) + Filename + #0 + 'octet' + #0;
278 FSock.SendString(s);
279 if FSock.LastError <> 0 then
280 Exit;
281 FData.Clear;
282 ser := 1;
283 repeat
284 if not RecvPacket(ser, s) then
285 Exit;
286 inc(ser);
287 WriteStrToStream(FData, s);
288// FData.Write(pointer(s)^, length(s));
289 until length(s) <> 512;
290 FData.Position := 0;
291 Result := true;
292 end;
293 finally
294 FSock.CloseSocket;
295 end;
296end;
297
298function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
299var
300 s: string;
301begin
302 Result := False;
303 FErrorCode := 0;
304 FErrorString := '';
305 FSock.CloseSocket;
306 FSock.Bind('0.0.0.0', FTargetPort);
307 if FSock.LastError = 0 then
308 begin
309 s := FSock.RecvPacket(FTimeout);
310 if FSock.LastError = 0 then
311 if Length(s) >= 4 then
312 begin
313 FRequestIP := FSock.GetRemoteSinIP;
314 FRequestPort := IntToStr(FSock.GetRemoteSinPort);
315 Req := DecodeInt(s, 1);
316 delete(s, 1, 2);
317 filename := Trim(SeparateLeft(s, #0));
318 s := SeparateRight(s, #0);
319 s := SeparateLeft(s, #0);
320 Result := lowercase(trim(s)) = 'octet';
321 end;
322 end;
323end;
324
325procedure TTFTPSend.ReplyError(Error: word; Description: string);
326var
327 s: string;
328begin
329 FSock.CloseSocket;
330 FSock.Connect(FRequestIP, FRequestPort);
331 s := CodeInt(5) + CodeInt(Error) + Description + #0;
332 FSock.SendString(s);
333 FSock.CloseSocket;
334end;
335
336function TTFTPSend.ReplyRecv: Boolean;
337var
338 s: string;
339 ser: integer;
340begin
341 Result := False;
342 FErrorCode := 0;
343 FErrorString := '';
344 FSock.CloseSocket;
345 FSock.Connect(FRequestIP, FRequestPort);
346 try
347 s := CodeInt(4) + CodeInt(0);
348 FSock.SendString(s);
349 FData.Clear;
350 ser := 1;
351 repeat
352 if not RecvPacket(ser, s) then
353 Exit;
354 inc(ser);
355 WriteStrToStream(FData, s);
356// FData.Write(pointer(s)^, length(s));
357 until length(s) <> 512;
358 FData.Position := 0;
359 Result := true;
360 finally
361 FSock.CloseSocket;
362 end;
363end;
364
365function TTFTPSend.ReplySend: Boolean;
366var
367 s: string;
368 ser: word;
369 n, n1, n2: integer;
370begin
371 Result := False;
372 FErrorCode := 0;
373 FErrorString := '';
374 FSock.CloseSocket;
375 FSock.Connect(FRequestIP, FRequestPort);
376 try
377 ser := 1;
378 FData.Position := 0;
379 n1 := FData.Size div 512;
380 n2 := FData.Size mod 512;
381 for n := 1 to n1 do
382 begin
383 s := ReadStrFromStream(FData, 512);
384// SetLength(s, 512);
385// FData.Read(pointer(s)^, 512);
386 if not Sendpacket(3, ser, s) then
387 Exit;
388 inc(ser);
389 end;
390 s := ReadStrFromStream(FData, n2);
391// SetLength(s, n2);
392// FData.Read(pointer(s)^, n2);
393 if not Sendpacket(3, ser, s) then
394 Exit;
395 Result := True;
396 finally
397 FSock.CloseSocket;
398 end;
399end;
400
401{==============================================================================}
402
403end.
Note: See TracBrowser for help on using the repository browser.