units/indy/KOLIdTrivialFTPServer.pas

   1 unit IdTrivialFTPServer;
   2
   3 interface
   4
   5 uses KOL { ,
   6   Classes } ,
   7   IdTrivialFTPBase,
   8   IdSocketHandle,
   9   IdUDPServer;
  10
  11 type
  12   TPeerInfo = record
  13     PeerIP: string;
  14     PeerPort: Integer;
  15   end;
  16
  17   TAccessFileEvent = procedure(Sender: TObject; var FileName: string; const
  18     PeerInfo: TPeerInfo;
  19     var GrantAccess: Boolean; var AStream: TStream; var FreeStreamOnComplete:
  20       Boolean) of object;
  21   TTransferCompleteEvent = procedure(Sender: TObject; const Success: Boolean;
  22     const PeerInfo: TPeerInfo; AStream: TStream; const WriteOperation: Boolean)
  23       of object;
  24
  25   TIdTrivialFTPServer = class(TIdUDPServer)
  26   protected
  27     FOnTransferComplete: TTransferCompleteEvent;
  28     FOnReadFile,
  29       FOnWriteFile: TAccessFileEvent;
  30     function StrToMode(mode: string): TIdTFTPMode;
  31   protected
  32     procedure DoReadFile(FileName: string; const Mode: TIdTFTPMode;
  33       const PeerInfo: TPeerInfo; RequestedBlockSize: Integer = 0); virtual;
  34     procedure DoWriteFile(FileName: string; const Mode: TIdTFTPMode;
  35       const PeerInfo: TPeerInfo; RequestedBlockSize: Integer = 0); virtual;
  36     procedure DoTransferComplete(const Success: Boolean; const PeerInfo:
  37       TPeerInfo; SourceStream: TStream; const WriteOperation: Boolean); virtual;
  38     procedure DoUDPRead(AData: TStream; ABinding: TIdSocketHandle); override;
  39   public
  40     constructor Create(axOwner: TComponent); override;
  41   published
  42     property OnReadFile: TAccessFileEvent read FOnReadFile write FOnReadFile;
  43     property OnWriteFile: TAccessFileEvent read FOnWriteFile write FOnWriteFile;
  44     property OnTransferComplete: TTransferCompleteEvent read FOnTransferComplete
  45       write FOnTransferComplete;
  46   end;
  47
  48 implementation
  49
  50 uses KOL,
  51   IdException,
  52   IdGlobal,
  53   IdResourceStrings,
  54   IdStack,
  55   IdUDPClient,
  56   SysUtils;
  57
  58 type
  59   TIdTFTPServerThread = class(TThread)
  60   private
  61     FStream: TStream;
  62     FUDPClient: TIdUDPClient;
  63     FRequestedBlkSize: Integer;
  64     EOT,
  65       FFreeStrm: Boolean;
  66     FOwner: TIdTrivialFTPServer;
  67     procedure TransferComplete;
  68   protected
  69     procedure Execute; override;
  70   public
  71      { constructor Create(AnOwner: TIdTrivialFTPServer; const Mode: TIdTFTPMode;
  72       const PeerInfo: TPeerInfo;
  73       AStream: TStream; const FreeStreamOnTerminate: boolean; const
  74         RequestedBlockSize: Integer = 0); virtual;
  75      }
  76 function Newreate (AnOwner: TIdTrivialFTPServer; const Mode: TIdTFTPMode;
  77       const PeerInfo: TPeerInfo;
  78       AStream: TStream; const FreeStreamOnTerminate: boolean; const
  79         RequestedBlockSize: Integer = 0):Preate;destructor Destroy;
  80    virtual; end;
  81
  82   TIdTFTPServerSendFileThread = class(TIdTFTPServerThread);
  83   TIdTFTPServerReceiveFileThread = class(TIdTFTPServerThread);
  84
  85  { constructor TIdTrivialFTPServer.Create(axOwner: TComponent);
  86  }
  87 function NewIdTrivialFTPServer (axOwner: TComponent):PIdTrivialFTPServer;begin
  88   inherited;
  89   DefaultPort := IdPORT_TFTP;
  90 end;
  91
  92 procedure TIdTrivialFTPServer.DoReadFile(FileName: string; const Mode:
  93   TIdTFTPMode;
  94   const PeerInfo: TPeerInfo; RequestedBlockSize: Integer = 0);
  95 var
  96   CanRead,
  97     FreeOnComplete: Boolean;
  98   SourceStream: TStream;
  99 begin
 100   CanRead := True;
 101   SourceStream := nil;
 102   FreeOnComplete := True;
 103   try
 104     if Assigned(FOnReadFile) then
 105       FOnReadFile(Self, FileName, PeerInfo, CanRead, SourceStream,
 106         FreeOnComplete);
 107     if CanRead then
 108     begin
 109       if SourceStream = nil then
 110       begin
 111         SourceStream := TFileStream.Create(FileName, fmOpenRead or
 112           fmShareDenyWrite);
 113         FreeOnComplete := True;
 114       end;
 115       TIdTFTPServerSendFileThread.Create(self, Mode, PeerInfo, SourceStream,
 116         FreeOnComplete, RequestedBlockSize);
 117     end
 118     else
 119       raise EIdTFTPAccessViolation.CreateFmt(RSTFTPAccessDenied, [FileName]);
 120   except
 121     on E: EFOpenError do
 122       raise EIdTFTPFileNotFound.Create(E.Message);
 123   end;
 124 end;
 125
 126 procedure TIdTrivialFTPServer.DoTransferComplete(const Success: Boolean;
 127   const PeerInfo: TPeerInfo; SourceStream: TStream; const WriteOperation:
 128     Boolean);
 129 begin
 130   if Assigned(FOnTransferComplete) then
 131     FOnTransferComplete(Self, Success, PeerInfo, SourceStream, WriteOperation)
 132   else
 133     SourceStream.Free;
 134 end;
 135
 136 procedure TIdTrivialFTPServer.DoUDPRead(AData: TStream; ABinding:
 137   TIdSocketHandle);
 138 var
 139   wOp: Word;
 140   s,
 141     FileName: string;
 142   RequestedBlkSize: integer;
 143   Mode: TIdTFTPMode;
 144   PeerInfo: TPeerInfo;
 145 begin
 146   inherited;
 147   try
 148     AData.ReadBuffer(wOp, SizeOf(wOp));
 149     wOp := GStack.WSNToHs(wOp);
 150     if wOp in [TFTP_RRQ, TFTP_WRQ] then
 151     begin
 152       SetLength(s, AData.Size - AData.Position);
 153       AData.ReadBuffer(s[1], Length(s));
 154       FileName := Fetch(s, #0);
 155       Mode := StrToMode(Fetch(s, #0));
 156       RequestedBlkSize := 0;
 157       if StrLComp(pchar(s), sBlockSize, Length(sBlockSize)) = 0 then
 158       begin
 159         Fetch(s, #0);
 160         RequestedBlkSize := StrToInt(Fetch(s, #0));
 161       end;
 162       PeerInfo.PeerIP := ABinding.PeerIP;
 163       PeerInfo.PeerPort := ABinding.PeerPort;
 164       if wOp = TFTP_RRQ then
 165         DoReadFile(FileName, Mode, PeerInfo, RequestedBlkSize)
 166       else
 167         DoWriteFile(FileName, Mode, PeerInfo, RequestedBlkSize);
 168     end
 169     else
 170       raise EIdTFTPIllegalOperation.CreateFmt(RSTFTPUnexpectedOp,
 171         [ABinding.PeerIP, ABinding.PeerPort]);
 172   except
 173     on E: EIdTFTPException do
 174       SendError(self, ABinding.PeerIP, ABinding.PeerPort, E);
 175     on E: Exception do
 176     begin
 177       SendError(self, ABinding.PeerIP, ABinding.PeerPort, E);
 178       raise;
 179     end;
 180   end;
 181 end;
 182
 183 procedure TIdTrivialFTPServer.DoWriteFile(FileName: string;
 184   const Mode: TIdTFTPMode; const PeerInfo: TPeerInfo;
 185   RequestedBlockSize: Integer);
 186 var
 187   CanWrite,
 188     FreeOnComplete: Boolean;
 189   DestinationStream: TStream;
 190 begin
 191   CanWrite := True;
 192   DestinationStream := nil;
 193   FreeOnComplete := True;
 194   try
 195     if Assigned(FOnWriteFile) then
 196       FOnWriteFile(Self, FileName, PeerInfo, CanWrite, DestinationStream,
 197         FreeOnComplete);
 198     if CanWrite then
 199     begin
 200       if DestinationStream = nil then
 201       begin
 202         DestinationStream := TFileStream.Create(FileName, fmCreate or
 203           fmShareDenyWrite);
 204         FreeOnComplete := True;
 205       end;
 206       TIdTFTPServerReceiveFileThread.Create(self, Mode, PeerInfo,
 207         DestinationStream, FreeOnComplete, RequestedBlockSize);
 208     end
 209     else
 210       raise EIdTFTPAccessViolation.CreateFmt(RSTFTPAccessDenied, [FileName]);
 211   except
 212     on E: EFCreateError do
 213       raise EIdTFTPAllocationExceeded.Create(E.Message);
 214   end;
 215 end;
 216
 217 function TIdTrivialFTPServer.StrToMode(mode: string): TIdTFTPMode;
 218 begin
 219   case PosInStrArray(mode, ['octet', 'binary', 'netascii'], False) of
 220     0, 1: Result := tfOctet;
 221     2: Result := tfNetAscii;
 222   else
 223     raise EIdTFTPIllegalOperation.CreateFmt(RSTFTPUnsupportedTrxMode, [mode]);
 224       // unknown mode
 225   end;
 226 end;
 227
 228  { constructor TIdTFTPServerThread.Create(AnOwner: TIdTrivialFTPServer;
 229   const Mode: TIdTFTPMode; const PeerInfo: TPeerInfo;
 230   AStream: TStream; const FreeStreamOnTerminate: boolean; const
 231     RequestedBlockSize: Integer);
 232  }
 233 function NewIdTFTPServerThread (AnOwner: TIdTrivialFTPServer;
 234   const Mode: TIdTFTPMode; const PeerInfo: TPeerInfo;
 235   AStream: TStream; const FreeStreamOnTerminate: boolean; const
 236     RequestedBlockSize: Integer):PIdTFTPServerThread;begin
 237   inherited Create(True);
 238   FStream := AStream;
 239   FUDPClient := TIdUDPClient.Create(nil);
 240   with FUDPClient do
 241   begin
 242     ReceiveTimeout := 1500;
 243     Host := PeerInfo.PeerIP;
 244     Port := PeerInfo.PeerPort;
 245     BufferSize := 516;
 246     FRequestedBlkSize := RequestedBlockSize;
 247   end;
 248   FFreeStrm := FreeStreamOnTerminate;
 249   FOwner := AnOwner;
 250   FreeOnTerminate := True;
 251   Resume;
 252 end;
 253
 254 destructor TIdTFTPServerThread.Destroy;
 255  virtual; begin
 256   if FFreeStrm then
 257     FreeAndNil(FStream);
 258   Synchronize(TransferComplete);
 259   FUDPClient.Free;
 260   inherited;
 261 end;
 262
 263 procedure TIdTFTPServerThread.Execute;
 264 var
 265   Response,
 266     Buffer: string;
 267   BlkCounter: integer;
 268   i,
 269     RetryCtr: integer;
 270 begin
 271   Response := '';
 272   BlkCounter := 0;
 273   RetryCtr := 0;
 274   EOT := False;
 275   SetLength(Response, Max(FRequestedBlkSize + hdrsize, FUDPClient.BufferSize));
 276   if FRequestedBlkSize > 0 then
 277   begin
 278     FUDPClient.BufferSize := Max(FRequestedBlkSize + hdrsize,
 279       FUDPClient.BufferSize);
 280     Response := WordToStr(GStack.WSHToNs(TFTP_OACK)) + 'blksize'#0
 281       + IntToStr(FUDPClient.BufferSize - hdrsize) + #0#0;
 282   end
 283   else
 284     Response := '';
 285   SetLength(Buffer, FUDPClient.BufferSize);
 286   try
 287     while true do
 288     begin
 289       if Response = '' then
 290       begin
 291         if (self is TIdTFTPServerReceiveFileThread) then
 292           Response := MakeAckPkt(BlkCounter)
 293         else
 294         begin
 295           BlkCounter := Word(succ(BlkCounter));
 296           Response := WordToStr(GStack.WSHToNs(TFTP_DATA)) +
 297             WordToStr(GStack.WSHToNs(Word(BlkCounter)));
 298           SetLength(Response, FUDPClient.BufferSize);
 299           i := FStream.Read(Response[hdrsize + 1], Length(Response) - hdrsize);
 300           SetLength(Response, i + hdrsize);
 301           EOT := i < FUDPClient.BufferSize - hdrsize;
 302         end;
 303         RetryCtr := 0;
 304       end;
 305       if RetryCtr = 3 then
 306         raise EIdTFTPIllegalOperation.Create(RSTimeOut);
 307       FUDPClient.Send(Response);
 308       Buffer := FUDPClient.ReceiveString;
 309       if Buffer = '' then
 310       begin
 311         if EOT then
 312           break;
 313         inc(RetryCtr);
 314         Continue;
 315       end;
 316       case GStack.WSNToHs(StrToWord(Buffer)) of
 317         TFTP_ACK:
 318           begin
 319             if not (self is TIdTFTPServerSendFileThread) then
 320             begin
 321               raise EIdTFTPIllegalOperation.CreateFmt(RSTFTPUnexpectedOp,
 322                 [FUDPClient.Host, FUDPClient.Port]);
 323             end;
 324             i := GStack.WSNToHs(StrToWord(Copy(Buffer, 3, 2)));
 325             if i = BlkCounter then
 326               Response := '';
 327             if EOT then break;
 328           end;
 329         TFTP_DATA:
 330           begin
 331             if not (self is TIdTFTPServerReceiveFileThread) then
 332             begin
 333               raise EIdTFTPIllegalOperation.CreateFmt(RSTFTPUnexpectedOp,
 334                 [FUDPClient.Host, FUDPClient.Port]);
 335             end;
 336             i := GStack.WSNToHs(StrToWord(Copy(Buffer, 3, 2)));
 337             if i = Word(BlkCounter + 1) then
 338             begin
 339               FStream.WriteBuffer(Buffer[hdrsize + 1], Length(Buffer) -
 340                 hdrsize);
 341               Response := '';
 342               BlkCounter := Word(succ(BlkCounter));
 343             end;
 344             EOT := Length(Buffer) < FUDPClient.BufferSize;
 345           end;
 346         TFTP_ERROR: Abort;
 347       else
 348         raise EIdTFTPIllegalOperation.CreateFmt(RSTFTPUnexpectedOp,
 349           [FUDPClient.Host, FUDPClient.Port]);
 350       end;
 351     end;
 352   except
 353     on E: EIdTFTPException do
 354       SendError(FUDPClient, E);
 355     on E: EWriteError do
 356       SendError(FUDPClient, ErrAllocationExceeded, Format(RSTFTPDiskFull,
 357         [FStream.Position]));
 358     on E: Exception do
 359       SendError(FUDPClient, E);
 360   end;
 361 end;
 362
 363 procedure TIdTFTPServerThread.TransferComplete;
 364 var
 365   PeerInfo: TPeerInfo;
 366 begin
 367   PeerInfo.PeerIP := FUDPClient.Host;
 368   PeerInfo.PeerPort := FUDPClient.Port;
 369   FOwner.DoTransferComplete(EOT, PeerInfo, FStream, self is
 370     TIdTFTPServerReceiveFileThread);
 371 end;
 372
 373 end.