dxftpbaseserver.pas

Well known and usefull component for delphi 7

end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandSITE(ClientThread: TDXClientThread; Parm: String);
begin
   if not CheckAuthorized( ClientThread, 'SIZE' ) then exit;

   DoLog( ClientThread, 'SIZE' , parm );

   If (parm='') or (uppercase(parm)='HELP') then Begin
      ClientThread.Socket.Writeln('214-The following SITE commands are supported.');
      ClientThread.Socket.Writeln('    HELP');
      ClientThread.Socket.Writeln('    DIRSTYLE');
      ClientThread.Socket.Writeln('214 HELP command sucessful.');
   end
   Else Begin
      if Uppercase(parm)='DIRSTYLE' then
         If WorkLikeDos then
            ClientThread.Socket.Writeln('200 MSDOS-like directory output is on')
         Else
            ClientThread.Socket.Writeln('200 UNIX-like directory output is on');
   End;
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandQUIT( ClientThread: TDXClientThread);
var
   lst: TStringList  ;
begin
//   if not CheckAuthorized( ClientThread, 'QUIT' ) then exit;

   DoLog( ClientThread, 'QUIT' , '');
   lst:= TStringList.Create ;
   try
      DoUserByeMessage( ClientThread , Lst ) ;

      SayGoodbye(ClientThread, lst);

   finally
     lst.free ;
   end;
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandTYPE(ClientThread: TDXClientThread; Parm: String);
begin
   if not CheckAuthorized( ClientThread, 'TYPE' ) then exit;

   DoLog( ClientThread, 'TYPE,' ,PARM);

   PUserSession(ClientThread.fpSessionData)^.DataMode:=0;
   If (Parm='I') or (Parm='i') then
      PUserSession(ClientThread.fpSessionData)^.DataMode:=1;
   ClientThread.Socket.Writeln('200 Type set to '+Parm+'.');
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandSTOR(ClientThread: TDXClientThread; FileName: String);
begin
   if not CheckAuthorized( ClientThread, 'STOR' ) then exit;

   DoLog( ClientThread, 'STOR' ,FileName );

   StoreFile( ClientThread , FileName , False ) ;
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.StoreFile(ClientThread: TDXClientThread;
  FileName: String; Append : Boolean);
var
   FileToRetr :String;
   FileHandle :Integer;
   Tries:Integer;
begin

   with PUserSession(ClientThread.fpSessionData)^ do Begin
      LastFileSize :=0 ;
      Abort:=False ;
      FileXfer := True ;

      FileToRetr:=CurrentDir+FileName;

      NewConnect.ipAddress:=PeerIPAddress;

      If PASV or DataSocket.Connect(NewConnect) then Begin

         if OnlyTransferFromSameIP and
         (DataSocket.PeerIPAddress <> ClientThread.Socket.PeerIPAddress ) then
         begin
               ClientThread.Socket.Writeln(ErrorText(550));
               // Should Disconnect ???
               exit ;
         end;

         if Append and not FileExists(FileToRetr) then begin
              ClientThread.Socket.WriteLn(ErrorText(502));
              exit ;
         end
         Else Begin
            RestPos:=0;
         end;

         if FileExists(FileToRetr) then begin

            FileHandle:=FileOpen(FileToRetr,fmOpenWrite or fmShareExclusive );

            If RestPos>0 then Begin
               ClientThread.Socket.Writeln(ErrorText(150)+', restarting at '+IntToStr(RestPos));
            End
            Else Begin
               ClientThread.Socket.Writeln(ErrorText(150)+#32+
               FileName+' to '+PeerIPAddress+'.');
            End;
         end
         Else Begin
            FileHandle:=FileCreate(FileToRetr);
            RestPos:=0;
            ClientThread.Socket.Writeln(ErrorText(150)+#32+
               FileName+' to '+PeerIPAddress+'.');
         End;
         // Seek the position specified by REST command... or 0 (beginning)

         if Assigned( fTransferBegin ) then
           fTransferBegin(  ClientThread, True ,Filename , FileSeek(FileHandle,0,2) ,-1);

         if Append then
            FileSeek(FileHandle, 0, 2)
         else
            FileSeek(FileHandle, RestPos, 0);

         RestPos:=0;
         Tries:=0;
         DataSocket.RestartCharactersPerSecondTimer;
         While DataSocket.Connected do Begin
            If Tries>100 then Begin
               Break;
            End;
            If DataSocket.Readable then Begin
               If DataSocket.CharactersToRead=0 then begin
                  Break; // dropped connection
               end;
               DataSocket.SaveTo(Filehandle,50000);
               Tries:=0;
            End
            Else Begin
               DoSleepEx(10);
               ProcessWindowsMessageQueue;
               Inc(Tries);
            End;
         End;
         SpeedReceive := DataSocket.CharactersPerSecondReceived ;
         if DataSocket.LastCommandStatus = 9999 then
            DoLog( ClientThread, 'STOR', 'ERROR', FileToRetr , DXString.SizeStamp(SpeedReceive) )
         else
            DoLog( ClientThread, 'STOR', 'FINISH', FileToRetr , DXString.SizeStamp(SpeedReceive) );

         if Assigned( fTransferEnd ) then
             FTransferEnd( ClientThread, TRUE ,Filename , FileSeek(FileHandle,0,2) , SpeedReceive );


         FileClose(FileHandle);
// Should delete or just let it rest there ??
//         if DataSocket.LastCommandStatus = 9999 then
//            DeleteFile( FileToRetr ) ;
         DataSocket.Disconnect;
         ClientThread.Socket.Writeln(ErrorText(226));
      End
      Else ClientThread.Socket.Writeln(ErrorText(450));
      FileXfer := False;

   end; {with}
end;

{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandCWD(ClientThread: TDXClientThread; Parm: String);
var
   ToDir:String;
begin
   if not CheckAuthorized( ClientThread, 'CWD' ) then exit;

   DoLog( ClientThread, 'CWD' ,PARM);

   with PUserSession(ClientThread.fpSessionData)^ do Begin

      If (Parm='') or (Parm='.') then Begin
         ClientThread.Socket.Writeln(ErrorText(250));
         Exit;
      End;

      Parm:=ToDosSlashes(Parm);

      If fHomeDirIsRoot and
         (CurrentDir=HomeDir) and
         ( '..' =Parm)    then Begin
         If length(ToDir)< Length(  HomeDir ) then Begin
            ClientThread.Socket.Writeln(ErrorText(550));
            Exit;
         End;
      End;

      If Parm[1]='\' then Begin
         Delete(Parm,1,1);
      End
      Else
         ToDir:=ChangeDir(CurrentDir, Parm);

      If fHomeDirIsRoot then begin
          ToDir:=ChangeDir(CurrentDir, Parm);
// Do Not allow indirections
         if Copy(ToDir,1,Length(HomeDir))<>HomeDir then
         ToDir:=HomeDir;
      end
      Else
          ToDir:=ChangeDir('\', Parm);

      If Copy(ToDir,Length(ToDir),1)<>'\' then
         ToDir:=ToDir+'\';
      if DirectoryExists(ToDir) then Begin
         CurrentDir := ToDir;
         ClientThread.Socket.WriteLn(ErrorText(250))
      End
      Else ClientThread.Socket.WriteLn(ErrorText(550))
   end; {with}
end;

{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandCDUP( ClientThread: TDXClientThread);
var
   ToDir:String;
begin
   if not CheckAuthorized( ClientThread, 'CDUP' ) then exit;

   DoLog( ClientThread, 'CDUP' , '');
   with PUserSession(ClientThread.fpSessionData)^ do begin
     ToDir:=ChangeDir(CurrentDir, '..');
     If fHomeDirIsRoot then Begin
        If length(ToDir)<Length(HomeDir) then Begin
           ClientThread.Socket.Writeln(ErrorText(550));
           Exit;
        End;
     End;
    // Do Not allow indirections
    if fHomeDirisRoot and
       (Copy(ToDir,1,Length(HomeDir))<>HomeDir) then
             ToDir:=HomeDir;

     if DirectoryExists(ToDir) then Begin
        CurrentDir := ToDir;
        ClientThread.Socket.WriteLn(ErrorText(250))
     End
     Else
        ClientThread.Socket.WriteLn(ErrorText(550))
   end;
end;

{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandOther(
  ClientThread: TDXClientThread; Command, Parm: String;
  var Handled: Boolean);
begin
   if not CheckAuthorized( ClientThread, 'CMD' ) then exit;

   DoLog( ClientThread, 'CMD=' + Command , 'PARM='+Parm);

   Handled:=True;
   ClientThread.Socket.WriteLn(ErrorText(550));
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandMKD(ClientThread: TDXClientThread; Parm: String);
Var
   ToDir:String;
begin
   if not CheckAuthorized( ClientThread, 'MKD' ) then exit;

   DoLog( ClientThread, 'MKD' , Parm);

   with PUserSession(ClientThread.fpSessionData)^ do begin

     // Check security first then do the following code
       ToDir:=ChangeDir(CurrentDir, Parm);
    //   if Pos(':',ToDir)>0 then Delete(ToDir,1,Pos(':',ToDir));

       If Copy(ToDir,1,Length(HomeDir))<> HomeDir then Begin
          ClientThread.Socket.Writeln(ErrorText(550)+' [1]');
          Exit;
       End;
       ForceDirectories(ToDir);
       If DirectoryExists(ToDir) then
          ClientThread.Socket.Writeln('257 MKD command successful.')
       Else
          ClientThread.Socket.Writeln(ErrorText(550)+' [2]');
    end;
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandRMD(ClientThread: TDXClientThread; Parm: String);
Var
   ToDir:String;

begin
   if not CheckAuthorized( ClientThread, 'RMD' ) then exit;

   DoLog( ClientThread, 'RMD' , Parm);
// Check security first then do the following code
   with PUserSession(ClientThread.fpSessionData)^ do begin
       ToDir:=ChangeDir(PUserSession(ClientThread.fpSessionData)^.CurrentDir, Parm);
       If Copy(ToDir,1,Length(HomeDir))<>HomeDir then Begin
          ClientThread.Socket.Writeln(ErrorText(550));
          Exit;
       End;
       If DirectoryExists(ToDir) then Begin
          If RemoveDir(ToDir) then
             ClientThread.Socket.Writeln('250 RMD command successful.')
          Else
             ClientThread.Socket.Writeln(ErrorText(550));
       End
       Else
          ClientThread.Socket.Writeln(ErrorText(550));
   end;
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandDELE(ClientThread: TDXClientThread; Filename: String);
var
 fullfname : string ;
begin
   if not CheckAuthorized( ClientThread, 'DELE' ) then exit;

   fullFname := PUserSession(ClientThread.fpSessionData)^.CurrentDir+FileName ;