source: trunk/Packages/synapse/ftptsend.pas

Last change on this file was 5, checked in by chronos, 13 years ago
  • Added: Required packages.
File size: 12.1 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 001.001.000 |
3|==============================================================================|
4| Content: Trivial FTP (TFTP) client and server |
5|==============================================================================|
6| Copyright (c)1999-2004, 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-2004. |
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
56unit ftptsend;
57
58interface
59
60uses
61 SysUtils, Classes,
62 blcksock, synautil;
63
64const
65 cTFTPProtocol = '69';
66
67 cTFTP_RRQ = word(1);
68 cTFTP_WRQ = word(2);
69 cTFTP_DTA = word(3);
70 cTFTP_ACK = word(4);
71 cTFTP_ERR = word(5);
72
73type
74 {:@abstract(Implementation of TFTP client and server)
75 Note: Are you missing properties for specify server address and port? Look to
76 parent @link(TSynaClient) too!}
77 TTFTPSend = class(TSynaClient)
78 private
79 FSock: TUDPBlockSocket;
80 FErrorCode: integer;
81 FErrorString: string;
82 FData: TMemoryStream;
83 FRequestIP: string;
84 FRequestPort: string;
85 function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
86 function RecvPacket(Serial: word; var Value: string): Boolean;
87 public
88 constructor Create;
89 destructor Destroy; override;
90
91 {:Upload @link(data) as file to TFTP server.}
92 function SendFile(const Filename: string): Boolean;
93
94 {:Download file from TFTP server to @link(data).}
95 function RecvFile(const Filename: string): Boolean;
96
97 {:Acts as TFTP server and wait for client request. When some request
98 incoming within Timeout, result is @true and parametres is filled with
99 information from request. You must handle this request, validate it, and
100 call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
101 to TFTP Client.}
102 function WaitForRequest(var Req: word; var filename: string): Boolean;
103
104 {:send error to TFTP client, when you acts as TFTP server.}
105 procedure ReplyError(Error: word; Description: string);
106
107 {:Accept uploaded file from TFTP client to @link(data), when you acts as
108 TFTP server.}
109 function ReplyRecv: Boolean;
110
111 {:Accept download request file from TFTP client and send content of
112 @link(data), when you acts as TFTP server.}
113 function ReplySend: Boolean;
114 published
115 {:Code of TFTP error.}
116 property ErrorCode: integer read FErrorCode;
117
118 {:Human readable decription of TFTP error. (if is sended by remote side)}
119 property ErrorString: string read FErrorString;
120
121 {:MemoryStream with datas for sending or receiving}
122 property Data: TMemoryStream read FData;
123
124 {:Address of TFTP remote side.}
125 property RequestIP: string read FRequestIP write FRequestIP;
126
127 {:Port of TFTP remote side.}
128 property RequestPort: string read FRequestPort write FRequestPort;
129 end;
130
131implementation
132
133constructor TTFTPSend.Create;
134begin
135 inherited Create;
136 FSock := TUDPBlockSocket.Create;
137 FTargetPort := cTFTPProtocol;
138 FData := TMemoryStream.Create;
139 FErrorCode := 0;
140 FErrorString := '';
141end;
142
143destructor TTFTPSend.Destroy;
144begin
145 FSock.Free;
146 FData.Free;
147 inherited Destroy;
148end;
149
150function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
151var
152 s, sh: string;
153begin
154 FErrorCode := 0;
155 FErrorString := '';
156 Result := false;
157 if Cmd <> 2 then
158 s := CodeInt(Cmd) + CodeInt(Serial) + Value
159 else
160 s := CodeInt(Cmd) + Value;
161 FSock.SendString(s);
162 s := FSock.RecvPacket(FTimeout);
163 if FSock.LastError = 0 then
164 if length(s) >= 4 then
165 begin
166 sh := CodeInt(4) + CodeInt(Serial);
167 if Pos(sh, s) = 1 then
168 Result := True
169 else
170 if s[1] = #5 then
171 begin
172 FErrorCode := DecodeInt(s, 3);
173 Delete(s, 1, 4);
174 FErrorString := SeparateLeft(s, #0);
175 end;
176 end;
177end;
178
179function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
180var
181 s: string;
182 ser: word;
183begin
184 FErrorCode := 0;
185 FErrorString := '';
186 Result := False;
187 Value := '';
188 s := FSock.RecvPacket(FTimeout);
189 if FSock.LastError = 0 then
190 if length(s) >= 4 then
191 if DecodeInt(s, 1) = 3 then
192 begin
193 ser := DecodeInt(s, 3);
194 if ser = Serial then
195 begin
196 Delete(s, 1, 4);
197 Value := s;
198 S := CodeInt(4) + CodeInt(ser);
199 FSock.SendString(s);
200 Result := FSock.LastError = 0;
201 end
202 else
203 begin
204 S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
205 FSock.SendString(s);
206 end;
207 end;
208 if DecodeInt(s, 1) = 5 then
209 begin
210 FErrorCode := DecodeInt(s, 3);
211 Delete(s, 1, 4);
212 FErrorString := SeparateLeft(s, #0);
213 end;
214end;
215
216function TTFTPSend.SendFile(const Filename: string): Boolean;
217var
218 s: string;
219 ser: word;
220 n, n1, n2: integer;
221begin
222 Result := False;
223 FErrorCode := 0;
224 FErrorString := '';
225 FSock.CloseSocket;
226 FSock.Connect(FTargetHost, FTargetPort);
227 try
228 if FSock.LastError = 0 then
229 begin
230 s := Filename + #0 + 'octet' + #0;
231 if not Sendpacket(2, 0, s) then
232 Exit;
233 ser := 1;
234 FData.Position := 0;
235 n1 := FData.Size div 512;
236 n2 := FData.Size mod 512;
237 for n := 1 to n1 do
238 begin
239 s := ReadStrFromStream(FData, 512);
240// SetLength(s, 512);
241// FData.Read(pointer(s)^, 512);
242 if not Sendpacket(3, ser, s) then
243 Exit;
244 inc(ser);
245 end;
246 s := ReadStrFromStream(FData, n2);
247// SetLength(s, n2);
248// FData.Read(pointer(s)^, n2);
249 if not Sendpacket(3, ser, s) then
250 Exit;
251 Result := True;
252 end;
253 finally
254 FSock.CloseSocket;
255 end;
256end;
257
258function TTFTPSend.RecvFile(const Filename: string): Boolean;
259var
260 s: string;
261 ser: word;
262begin
263 Result := False;
264 FErrorCode := 0;
265 FErrorString := '';
266 FSock.CloseSocket;
267 FSock.Connect(FTargetHost, FTargetPort);
268 try
269 if FSock.LastError = 0 then
270 begin
271 s := CodeInt(1) + Filename + #0 + 'octet' + #0;
272 FSock.SendString(s);
273 if FSock.LastError <> 0 then
274 Exit;
275 FData.Clear;
276 ser := 1;
277 repeat
278 if not RecvPacket(ser, s) then
279 Exit;
280 inc(ser);
281 WriteStrToStream(FData, s);
282// FData.Write(pointer(s)^, length(s));
283 until length(s) <> 512;
284 FData.Position := 0;
285 Result := true;
286 end;
287 finally
288 FSock.CloseSocket;
289 end;
290end;
291
292function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
293var
294 s: string;
295begin
296 Result := False;
297 FErrorCode := 0;
298 FErrorString := '';
299 FSock.CloseSocket;
300 FSock.Bind('0.0.0.0', FTargetPort);
301 if FSock.LastError = 0 then
302 begin
303 s := FSock.RecvPacket(FTimeout);
304 if FSock.LastError = 0 then
305 if Length(s) >= 4 then
306 begin
307 FRequestIP := FSock.GetRemoteSinIP;
308 FRequestPort := IntToStr(FSock.GetRemoteSinPort);
309 Req := DecodeInt(s, 1);
310 delete(s, 1, 2);
311 filename := Trim(SeparateLeft(s, #0));
312 s := SeparateRight(s, #0);
313 s := SeparateLeft(s, #0);
314 Result := lowercase(trim(s)) = 'octet';
315 end;
316 end;
317end;
318
319procedure TTFTPSend.ReplyError(Error: word; Description: string);
320var
321 s: string;
322begin
323 FSock.CloseSocket;
324 FSock.Connect(FRequestIP, FRequestPort);
325 s := CodeInt(5) + CodeInt(Error) + Description + #0;
326 FSock.SendString(s);
327 FSock.CloseSocket;
328end;
329
330function TTFTPSend.ReplyRecv: Boolean;
331var
332 s: string;
333 ser: integer;
334begin
335 Result := False;
336 FErrorCode := 0;
337 FErrorString := '';
338 FSock.CloseSocket;
339 FSock.Connect(FRequestIP, FRequestPort);
340 try
341 s := CodeInt(4) + CodeInt(0);
342 FSock.SendString(s);
343 FData.Clear;
344 ser := 1;
345 repeat
346 if not RecvPacket(ser, s) then
347 Exit;
348 inc(ser);
349 WriteStrToStream(FData, s);
350// FData.Write(pointer(s)^, length(s));
351 until length(s) <> 512;
352 FData.Position := 0;
353 Result := true;
354 finally
355 FSock.CloseSocket;
356 end;
357end;
358
359function TTFTPSend.ReplySend: Boolean;
360var
361 s: string;
362 ser: word;
363 n, n1, n2: integer;
364begin
365 Result := False;
366 FErrorCode := 0;
367 FErrorString := '';
368 FSock.CloseSocket;
369 FSock.Connect(FRequestIP, FRequestPort);
370 try
371 ser := 1;
372 FData.Position := 0;
373 n1 := FData.Size div 512;
374 n2 := FData.Size mod 512;
375 for n := 1 to n1 do
376 begin
377 s := ReadStrFromStream(FData, 512);
378// SetLength(s, 512);
379// FData.Read(pointer(s)^, 512);
380 if not Sendpacket(3, ser, s) then
381 Exit;
382 inc(ser);
383 end;
384 s := ReadStrFromStream(FData, n2);
385// SetLength(s, n2);
386// FData.Read(pointer(s)^, n2);
387 if not Sendpacket(3, ser, s) then
388 Exit;
389 Result := True;
390 finally
391 FSock.CloseSocket;
392 end;
393end;
394
395{==============================================================================}
396
397end.
Note: See TracBrowser for help on using the repository browser.