02ab154a09
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@70 7c85be65-684b-0410-a082-b2ed4fbef004
353 lines
10 KiB
ObjectPascal
353 lines
10 KiB
ObjectPascal
{==============================================================================|
|
|
| Project : Ararat Synapse | 001.000.002 |
|
|
|==============================================================================|
|
|
| Content: Trivial FTP (TFTP) client and server |
|
|
|==============================================================================|
|
|
| Copyright (c)1999-2003, Lukas Gebauer |
|
|
| All rights reserved. |
|
|
| |
|
|
| Redistribution and use in source and binary forms, with or without |
|
|
| modification, are permitted provided that the following conditions are met: |
|
|
| |
|
|
| Redistributions of source code must retain the above copyright notice, this |
|
|
| list of conditions and the following disclaimer. |
|
|
| |
|
|
| Redistributions in binary form must reproduce the above copyright notice, |
|
|
| this list of conditions and the following disclaimer in the documentation |
|
|
| and/or other materials provided with the distribution. |
|
|
| |
|
|
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
|
| be used to endorse or promote products derived from this software without |
|
|
| specific prior written permission. |
|
|
| |
|
|
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
|
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
|
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
|
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
|
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
|
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
|
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
|
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
|
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
|
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
|
| DAMAGE. |
|
|
|==============================================================================|
|
|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
|
| Portions created by Lukas Gebauer are Copyright (c)2003. |
|
|
| All Rights Reserved. |
|
|
|==============================================================================|
|
|
| Contributor(s): |
|
|
|==============================================================================|
|
|
| History: see HISTORY.HTM from distribution package |
|
|
| (Found at URL: http://www.ararat.cz/synapse/) |
|
|
|==============================================================================}
|
|
|
|
// RFC-1350
|
|
|
|
{$IFDEF FPC}
|
|
{$MODE DELPHI}
|
|
{$ENDIF}
|
|
{$Q-}
|
|
{$H+}
|
|
|
|
unit ftptsend;
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, Classes,
|
|
blcksock, synautil;
|
|
|
|
const
|
|
cTFTPProtocol = '69';
|
|
|
|
type
|
|
TTFTPSend = class(TSynaClient)
|
|
private
|
|
FSock: TUDPBlockSocket;
|
|
FErrorCode: integer;
|
|
FErrorString: string;
|
|
FData: TMemoryStream;
|
|
FRequestIP: string;
|
|
FRequestPort: string;
|
|
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
|
function RecvPacket(Serial: word; var Value: string): Boolean;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function SendFile(const Filename: string): Boolean;
|
|
function RecvFile(const Filename: string): Boolean;
|
|
function WaitForRequest(var Req: word; var filename: string): Boolean;
|
|
procedure ReplyError(Error: word; Description: string);
|
|
function ReplyRecv: Boolean;
|
|
function ReplySend: Boolean;
|
|
published
|
|
property ErrorCode: integer read FErrorCode;
|
|
property ErrorString: string read FErrorString;
|
|
property Data: TMemoryStream read FData;
|
|
property RequestIP: string read FRequestIP write FRequestIP;
|
|
property RequestPort: string read FRequestPort write FRequestPort;
|
|
end;
|
|
|
|
implementation
|
|
|
|
constructor TTFTPSend.Create;
|
|
begin
|
|
inherited Create;
|
|
FSock := TUDPBlockSocket.Create;
|
|
FTargetPort := cTFTPProtocol;
|
|
FData := TMemoryStream.Create;
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
end;
|
|
|
|
destructor TTFTPSend.Destroy;
|
|
begin
|
|
FSock.Free;
|
|
FData.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
|
var
|
|
s, sh: string;
|
|
begin
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
Result := false;
|
|
if Cmd <> 2 then
|
|
s := CodeInt(Cmd) + CodeInt(Serial) + Value
|
|
else
|
|
s := CodeInt(Cmd) + Value;
|
|
FSock.SendString(s);
|
|
s := FSock.RecvPacket(FTimeout);
|
|
if FSock.LastError = 0 then
|
|
if length(s) >= 4 then
|
|
begin
|
|
sh := CodeInt(4) + CodeInt(Serial);
|
|
if Pos(sh, s) = 1 then
|
|
Result := True
|
|
else
|
|
if s[1] = #5 then
|
|
begin
|
|
FErrorCode := DecodeInt(s, 3);
|
|
Delete(s, 1, 4);
|
|
FErrorString := SeparateLeft(s, #0);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
|
|
var
|
|
s: string;
|
|
ser: word;
|
|
begin
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
Result := False;
|
|
Value := '';
|
|
s := FSock.RecvPacket(FTimeout);
|
|
if FSock.LastError = 0 then
|
|
if length(s) >= 4 then
|
|
if DecodeInt(s, 1) = 3 then
|
|
begin
|
|
ser := DecodeInt(s, 3);
|
|
if ser = Serial then
|
|
begin
|
|
Delete(s, 1, 4);
|
|
Value := s;
|
|
S := CodeInt(4) + CodeInt(ser);
|
|
FSock.SendString(s);
|
|
Result := FSock.LastError = 0;
|
|
end
|
|
else
|
|
begin
|
|
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
|
|
FSock.SendString(s);
|
|
end;
|
|
end;
|
|
if DecodeInt(s, 1) = 5 then
|
|
begin
|
|
FErrorCode := DecodeInt(s, 3);
|
|
Delete(s, 1, 4);
|
|
FErrorString := SeparateLeft(s, #0);
|
|
end;
|
|
end;
|
|
|
|
function TTFTPSend.SendFile(const Filename: string): Boolean;
|
|
var
|
|
s: string;
|
|
ser: word;
|
|
n, n1, n2: integer;
|
|
begin
|
|
Result := False;
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
FSock.CloseSocket;
|
|
FSock.Connect(FTargetHost, FTargetPort);
|
|
try
|
|
if FSock.LastError = 0 then
|
|
begin
|
|
s := Filename + #0 + 'octet' + #0;
|
|
if not Sendpacket(2, 0, s) then
|
|
Exit;
|
|
ser := 1;
|
|
FData.Position := 0;
|
|
n1 := FData.Size div 512;
|
|
n2 := FData.Size mod 512;
|
|
for n := 1 to n1 do
|
|
begin
|
|
SetLength(s, 512);
|
|
FData.Read(pointer(s)^, 512);
|
|
if not Sendpacket(3, ser, s) then
|
|
Exit;
|
|
inc(ser);
|
|
end;
|
|
SetLength(s, n2);
|
|
FData.Read(pointer(s)^, n2);
|
|
if not Sendpacket(3, ser, s) then
|
|
Exit;
|
|
Result := True;
|
|
end;
|
|
finally
|
|
FSock.CloseSocket;
|
|
end;
|
|
end;
|
|
|
|
function TTFTPSend.RecvFile(const Filename: string): Boolean;
|
|
var
|
|
s: string;
|
|
ser: word;
|
|
begin
|
|
Result := False;
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
FSock.CloseSocket;
|
|
FSock.Connect(FTargetHost, FTargetPort);
|
|
try
|
|
if FSock.LastError = 0 then
|
|
begin
|
|
s := CodeInt(1) + Filename + #0 + 'octet' + #0;
|
|
FSock.SendString(s);
|
|
if FSock.LastError <> 0 then
|
|
Exit;
|
|
FData.Clear;
|
|
ser := 1;
|
|
repeat
|
|
if not RecvPacket(ser, s) then
|
|
Exit;
|
|
inc(ser);
|
|
FData.Write(pointer(s)^, length(s));
|
|
until length(s) <> 512;
|
|
FData.Position := 0;
|
|
Result := true;
|
|
end;
|
|
finally
|
|
FSock.CloseSocket;
|
|
end;
|
|
end;
|
|
|
|
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
|
|
var
|
|
s: string;
|
|
begin
|
|
Result := False;
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
FSock.CloseSocket;
|
|
FSock.Bind('0.0.0.0', FTargetPort);
|
|
if FSock.LastError = 0 then
|
|
begin
|
|
s := FSock.RecvPacket(FTimeout);
|
|
if FSock.LastError = 0 then
|
|
if Length(s) >= 4 then
|
|
begin
|
|
FRequestIP := FSock.GetRemoteSinIP;
|
|
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
|
|
Req := DecodeInt(s, 1);
|
|
delete(s, 1, 2);
|
|
filename := SeparateLeft(s, #0);
|
|
s := SeparateRight(s, #0);
|
|
s := SeparateLeft(s, #0);
|
|
Result := lowercase(s) = 'octet';
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTFTPSend.ReplyError(Error: word; Description: string);
|
|
var
|
|
s: string;
|
|
begin
|
|
FSock.CloseSocket;
|
|
FSock.Connect(FRequestIP, FRequestPort);
|
|
s := CodeInt(5) + CodeInt(Error) + Description + #0;
|
|
FSock.SendString(s);
|
|
FSock.CloseSocket;
|
|
end;
|
|
|
|
function TTFTPSend.ReplyRecv: Boolean;
|
|
var
|
|
s: string;
|
|
ser: integer;
|
|
begin
|
|
Result := False;
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
FSock.CloseSocket;
|
|
FSock.Connect(FRequestIP, FRequestPort);
|
|
try
|
|
s := CodeInt(4) + CodeInt(0);
|
|
FSock.SendString(s);
|
|
FData.Clear;
|
|
ser := 1;
|
|
repeat
|
|
if not RecvPacket(ser, s) then
|
|
Exit;
|
|
inc(ser);
|
|
FData.Write(pointer(s)^, length(s));
|
|
until length(s) <> 512;
|
|
FData.Position := 0;
|
|
Result := true;
|
|
finally
|
|
FSock.CloseSocket;
|
|
end;
|
|
end;
|
|
|
|
function TTFTPSend.ReplySend: Boolean;
|
|
var
|
|
s: string;
|
|
ser: word;
|
|
n, n1, n2: integer;
|
|
begin
|
|
Result := False;
|
|
FErrorCode := 0;
|
|
FErrorString := '';
|
|
FSock.CloseSocket;
|
|
FSock.Connect(FRequestIP, FRequestPort);
|
|
try
|
|
ser := 1;
|
|
FData.Position := 0;
|
|
n1 := FData.Size div 512;
|
|
n2 := FData.Size mod 512;
|
|
for n := 1 to n1 do
|
|
begin
|
|
SetLength(s, 512);
|
|
FData.Read(pointer(s)^, 512);
|
|
if not Sendpacket(3, ser, s) then
|
|
Exit;
|
|
inc(ser);
|
|
end;
|
|
SetLength(s, n2);
|
|
FData.Read(pointer(s)^, n2);
|
|
if not Sendpacket(3, ser, s) then
|
|
Exit;
|
|
Result := True;
|
|
finally
|
|
FSock.CloseSocket;
|
|
end;
|
|
end;
|
|
|
|
{==============================================================================}
|
|
|
|
end.
|