dxftpbaseserver.pas

Well known and usefull component for delphi 7

//ss: Clear Header
   Header.Clear ;
//ss: Get User message
   Header.Free;

finally

   try
     if Assigned( fDisconnect ) then
          fDisconnect( ClientThread ) ;
   finally
     UserRec:=PUserSession(ClientThread.fpSessionData);
     ClientThread.fpSessionData:=Nil;
     // Move to on Disconnect
     If UserRec<>Nil then Begin
        UserRec^.DataSocket.Free;
        UserRec^.NewConnect.Free;
  //      UsrData^.ReleaseDataModule ;
     End;

     Dispose(UserRec);
   end;
end;
end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandRETR(ClientThread: TDXClientThread;
  FileName: String);
var
   FileToRetr:String;
   FileHandle:Integer;
begin
   if not CheckAuthorized( ClientThread, 'RETR' ) then exit;

   DoLog( ClientThread , 'RETR' , FileName );

   With PUserSession(ClientThread.fpSessionData)^ do Begin
      // Normalize Filename
      LastFileSize :=0 ;
      Abort:=False ;
      FileXfer := True ;
      FileName :=ToDosSlashes(FileName);
      //## check Homedir / ../ ..\ Currentdir todir

      If Copy(Filename , 1 , 1 ) = '\' then Begin
         If fHomeDirIsRoot then
            FileName:=NoBackSlash(HomeDir)+FileName;
         FileToRetr:=FileName;
      End
      Else
         FileToRetr:=CurrentDir+FileName;

      if FileExists(FileToRetr) and
         (Not DirectoryExists(FileName)) then begin
         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;
            FileHandle := FileOpen(FileToRetr, fmOpenRead or fmShareDenyWrite  );//#None);
            ClientThread.Socket.Writeln(ErrorText(150)+
               #32+FileName+' ('+IntToStr(FileSeek(FileHandle,0,2))+'bytes) to '+
               PeerIPAddress+'.');
            // Seek the position specified by REST command...or 0 (beginning)

            if Assigned( fTransferBegin ) then
               fTransferBegin( ClientThread, false , FileToRetr , FileSeek(FileHandle,0,2), -1 );

            FileSeek(FileHandle, PUserSession(ClientThread.fpSessionData)^.RestPos, 0);

            RestPos:=0;

            DataSocket.RestartCharactersPerSecondTimer;

            While not DataSocket.SendFrom(FileHandle) do Begin
               If not DataSocket.Connected then Break;
               DoSleepEx(1);
               ProcessWindowsMessageQueue;
            End;

            FileClose(FileHandle);

            SpeedSend := DataSocket.CharactersPerSecondWritten ;
            if Assigned( fTransferEnd ) then
               FTransferEnd( ClientThread, False ,Filename , FileSeek(FileHandle,0,2) , SpeedSend );

            DataSocket.Disconnect;
            ClientThread.Socket.Writeln(ErrorText(226));
         End
         Else ClientThread.Socket.Writeln(ErrorText(421));
      end
      else
         ClientThread.Socket.WriteLn(ErrorText(450));
      FileXfer := False ;
   end; {with}
end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandPORT(ClientThread: TDXClientThread; Parm : String);
Var
  LoInt,HoInt:Byte;
begin
   if not CheckAuthorized( ClientThread, 'PORT' ) then exit;

   DoLog( ClientThread, 'PORT,' ,Parm);

   with PUserSession(ClientThread.fpSessionData)^ do Begin
      Fetch(Parm,',',False); {skip 1st octet}
      Fetch(Parm,',',False); {skip 2nd octet}
      Fetch(Parm,',',False); {skip 3rd octet}
      Fetch(Parm,',',False); {skip 4th octet}
      LoInt:=StrToint(Fetch(Parm,',',False)); {5th octet}
      HoInt:=StrToInt(Parm);

      If DataSocket<>Nil then
               DataSocket.Free;
      NewConnect.Port:=(LoInt*256)+HoInt; // Ozz
      DataSocket:=TDXSock.Create(Nil);
//05-01-12 -<
      DataSocket.OnWriteBuffer := DoDataSocketOnWrite;
      DataSocket.OnReadBuffer  := DoDataSocketOnRead;
      if DataSocket.TLSClientThread = NIL then
           DataSocket.TLSClientThread := ClientThread ;
//05-01-12  >-
      PASV := FALSE;
   End; {with}

   ClientThread.Socket.Writeln(ErrorText(200));
end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandNLST(ClientThread: TDXClientThread;
  Parm: String);
var
   Err:Integer;
   SRec:TSearchRec;
begin
   if not CheckAuthorized( ClientThread, 'NLST' ) then exit;

   DoLog( ClientThread, 'NLST,', PARM);
   with PUserSession(ClientThread.fpSessionData)^ do Begin
      Abort:=False ;
      FileXfer :=  False  ;


      NewConnect.ipAddress:=PeerIPAddress;

      If PASV or DataSocket.Connect(NewConnect) then Begin
         ClientThread.Socket.Writeln(ErrorText(150)+
            #32+PeerIPAddress);

            //##Checar Path
        If PARM='' then PARM:='*.*';   
         Err:=FindFirst(CurrentDir+parm ,faAnyFile,SRec);
         While Err=0 do Begin
            If ((SRec.Attr and faDirectory)<>0) and (SRec.Name='.') then {absorb}
            Else DataSocket.Writeln(SRec.Name);
            Err:=FindNext(SRec);
         End;
         SysUtils.FindClose(SRec);

         DataSocket.Disconnect;
         ClientThread.Socket.Writeln(ErrorText(226));
      End
      Else ClientThread.Socket.Writeln(ErrorText(450));
   end; {with}
end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandLIST(ClientThread: TDXClientThread; Parm: String);
var
   lsPath,DirLine,StrTime,StrSize,todir:String;
   Err:Integer;
   SRec:TSearchRec;
begin
   if not CheckAuthorized( ClientThread, 'LIST' ) then exit;

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

   If Parm='' then Parm:='*.*';
   With PUserSession(ClientThread.fpSessionData)^ do Begin
      Abort:=False ;
      FileXfer :=  False  ;
      NewConnect.ipAddress:=PeerIPAddress;

      If PASV or DataSocket.Connect(NewConnect) then Begin
        ClientThread.Socket.Writeln(ErrorText(150)+ #32+PeerIPAddress);


         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);
//##
//LIST command - find lsPath - second lsPath:=... comment out - the line before is using the PARM which is what we need.

        lsPath := ExtractFilePath( Todir ) + '*.*';
        Err:=FindFirst( lsPath ,faAnyFile,SRec);

        While Err=0 do Begin
              // Build DOS-like directory tree, if you want you can
              // easily build a different one by using standard Delphi
              // string and file commands
            if ((SRec.Attr and faDirectory)>0) and (SRec.Name='.') then {absorb}
            Else Begin
               If WorkLikeDos then Begin
                  if (SRec.Attr and faDirectory)>0 then
                     StrSize:='       <DIR>         '
                  else
                     Str(SRec.Size:21,StrSize);

                  StrTime:=FormatDateTime('mm-dd-yy  hh:mmAM/PM',FileDateToDateTime(SRec.Time));
                  DirLine:=StrTime+StrSize+' '+SRec.Name;
               End
               Else Begin
                  Str(SRec.Size:12,StrSize);
                  StrTime:=FormatDateTime(' mmm dd ',FileDateToDateTime(SRec.Time));
                  If FormatDateTime('yy',FileDateToDateTime(SRec.Time))=
                     FormatDateTime('yy',Now) then
                     StrTime:=StrTime+FormatDateTime('hh:mm',FileDateToDateTime(SRec.Time))
                  Else
                     StrTime:=StrTime+FormatDateTime(' yyyy',FileDateToDateTime(SRec.Time));
                  if (SRec.Attr and faDirectory)>0 then
                     Dirline:='d'
                  Else
                     Dirline:='-';

                  DirLine:=Dirline+'rw-rw-rw-   1 owner    group    '+StrSize+#32+StrTime+#32+SRec.Name;
               End;
               DataSocket.Writeln(DirLine);
            End;
            Err:=FindNext(SRec);
        End; {while}
        ClientThread.Socket.Writeln(ErrorText(226));
        SysUtils.FindClose(SRec);
        DataSocket.Disconnect;
      End
      Else
         ClientThread.Socket.Writeln(ErrorText(450));
   end; {with}
end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandREST(ClientThread: TDXClientThread;
  Parm: String);
begin
   if not CheckAuthorized( ClientThread, 'REST' ) then exit;
   DoLog( ClientThread, 'REST,' , PARM);
   PUserSession(ClientThread.fpSessionData)^.RestPos :=
{$IFDEF VER100}
      StrToInt(Parm);
{$ELSE}
      StrToInt64(Parm);
{$ENDIF}
   ClientThread.Socket.WriteLn(ErrorText(350)+', restarting at '+Parm);
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandNOOP( ClientThread: TDXClientThread);
begin
   // Noop does nothing except avoid timeouts
   if not CheckAuthorized( ClientThread, 'NOOP' ) then exit;

   Inc( PUserSession(ClientThread.fpSessionData)^.NoopCount );

   DoLog( ClientThread, 'NOOP' ,
      IntToStr( PUserSession(ClientThread.fpSessionData)^.NoopCount ) );

   ClientThread.Socket.Writeln(ErrorText(200));
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandPWD(ClientThread: TDXClientThread);
Var
   ToDir:String;
begin
   if not CheckAuthorized( ClientThread, 'PWD' ) then exit;


   ToDir:=ToUnixSlashes(PUserSession(ClientThread.fpSessionData)^.CurrentDir);

   If fHomeDirIsRoot then
      Delete(ToDir,1,Length(PUserSession(ClientThread.fpSessionData)^.HomeDir)); // SYNCH

   If (ToDir='') or (Copy(ToDir,1,1)<>'/') then
            ToDir:='/'; // SYNCH

   DoLog( ClientThread, 'PWD' , ToDir);

   ClientThread.Socket.Writeln('257 "'+ToDir+'" is current directory.');
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandREIN( ClientThread: TDXClientThread);
begin
   DoLog( ClientThread, 'REIN' , '');
   ClientThread.Socket.Writeln(ErrorText(220));
   PUserSession(ClientThread.fpSessionData)^.AuthorizedState:=False;
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandSYST( ClientThread: TDXClientThread);
begin
   if not CheckAuthorized( ClientThread, 'SYST' ) then exit;
   DoLog( ClientThread, 'SYST' , '');
   ClientThread.Socket.Writeln(ErrorText(215));
end;
{-----------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandSTAT(ClientThread: TDXClientThread;
  Parm: String);
begin
   if not CheckAuthorized( ClientThread, 'STAT' ) then exit;

   DoLog( ClientThread, 'STAT' , parm );

   ClientThread.Socket.Writeln('211-FTP Server Status.');
   ClientThread.Socket.Writeln('    Version 5.0');
   ClientThread.Socket.Writeln('    Connected to '+
      PUserSession(ClientThread.fpSessionData)^.PeerIPAddress);
   ClientThread.Socket.Writeln('    Logged in as '+
      PUserSession(ClientThread.fpSessionData)^.User);
   ClientThread.Socket.Writeln('211 End of status.');