ftpserv1.pas

Tu may tinh den may chu

    sc.y := nLines;
    SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), sc);
    SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
                            BACKGROUND_BLUE or BACKGROUND_GREEN or
                            BACKGROUND_RED or BACKGROUND_INTENSITY);
    sc.x := 0;
    sc.y := 0;
    FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
                               BACKGROUND_BLUE or BACKGROUND_GREEN or
                               BACKGROUND_RED or BACKGROUND_INTENSITY,
                               nCols * nLines, sc, N);
end;
{$ENDIF}


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FormCreate(Sender: TObject);
begin
    { Build Ini file name }
    FIniFileName := LowerCase(ExtractFileName(Application.ExeName));
    FIniFileName := Copy(FIniFileName, 1, Length(FIniFileName) - 3) + 'ini';
    { Create the Log object }
    Log := TLogMsg.Create(Self);

{$IFNDEF VER80}
{    BigConsole(80, 100); }
{$ENDIF}
    InfoMemo.Clear;
    GreenImage.Visible := FALSE;
    RedImage.Visible   := TRUE;
    RedImage.Top       := GreenImage.Top;
    RedImage.Left      := GreenImage.Left;

    Image2.Visible := FALSE;
    Image1.Visible   := TRUE;
    Image1.Top       := Image2.Top;
    Image1.Left      := Image2.Left;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.StartServer;
var
    wsi     : TWSADATA;
begin
    GreenImage.Visible := FALSE;
    RedImage.Visible   := TRUE;
    Update;
    StartFTPService1.Enabled:=False;
    StopFTPService1.Enabled:=True;
    { Display version info for program and use components }
    wsi := WinsockInfo;
//    InfoMemo.Lines.Add(Trim(CopyRight));
//    InfoMemo.Lines.Add('Using:');
//    InfoMemo.Lines.Add('   ' + WSocket.CopyRight);
//    InfoMemo.Lines.Add('   ' + FtpSrv.CopyRight);
//    InfoMemo.Lines.Add('    Winsock:');
//    InfoMemo.Lines.Add('        Version ' +
{            Format('%d.%d', [WinsockInfo.wHighVersion shr 8,
                             WinsockInfo.wHighVersion and 15]));
    InfoMemo.Lines.Add('        ' + StrPas(@wsi.szDescription));
    InfoMemo.Lines.Add('        ' + StrPas(@wsi.szSystemStatus)); }
{$IFNDEF VER100}
    { A bug in Delphi 3 makes lpVendorInfo invalid }
    if wsi.lpVendorInfo <> nil then
        InfoMemo.Lines.Add('        ' + StrPas(wsi.lpVendorInfo));
{$ENDIF}
    FtpServer1.Start;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.StopServer;
begin
    FtpServer1.Stop;
    FtpServer1.DisconnectAll;
    StartFTPService1.Enabled:=True;
    StopFTPService1.Enabled:=False;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.MnuQuitClick(Sender: TObject);
begin
    Close;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.StopFTPService1Click(Sender: TObject);
begin
    StopServer;
    SpeedButton2.Caption:='Start'+#13+'FTP Service';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.StartFTPService1Click(Sender: TObject);
begin
    StartServer;
    SpeedButton2.Caption:='Stop'+#13+'FTP Service';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.ImagesDblClick(Sender: TObject);
begin
    if FtpServer1.Active then
        StopServer
    else
        StartServer;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.UpdateClientCount;
begin
    if FtpServer1.ClientCount = 0 then
        ClientCountLabel.Caption := 'No user'
    else
        ClientCountLabel.Caption := IntToStr(FtpServer1.ClientCount) + ' users';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1ClientConnect(Sender: TObject;
  Client: TFtpCtrlSocket; Error: Word);
begin
    { The next test shows how to refuse a client }
    if Client.GetPeerAddr = '193.121.12.25' then begin
        Client.SendStr('421 Connection not allowed.' + #13#10);
        Client.Close;
        Exit;
    end;
    InfoMemo.Lines.Add('[Info] ' + Client.GetPeerAddr + ' connected');
    UpdateClientCount;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1ClientDisconnect(Sender: TObject;
  Client: TFtpCtrlSocket; Error: Word);
begin
    InfoMemo.Lines.Add('[Info] ' + Client.GetPeerAddr + ' disconnected');
    UpdateClientCount;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1Start(Sender: TObject);
begin
    GreenImage.Visible := TRUE;
    RedImage.Visible   := FALSE;
    InfoMemo.Lines.Add('^_^ FTP Service started.');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1Stop(Sender: TObject);
begin
    GreenImage.Visible := FALSE;
    RedImage.Visible   := TRUE;
    InfoMemo.Lines.Add('*_* FTP Service stopped.');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1StorSessionConnected(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('[Error] ' + Client.GetPeerAddr +
                           ' Data session failed to open. Error #' +
                           IntToStr(Error));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1StorSessionClosed(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('[Error] ' + Client.GetPeerAddr +
                           ' Data session closed. Error #' + IntToStr(Error));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1RetrDataSent(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('[Error] ' + Client.GetPeerAddr +
                           ' Data sent. Error #' + IntToStr(Error));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is called when the data session for a get file has     }
{ been opened. This is a good place build a file or a stream if the data    }
{ requested is not already stored in a file on the file system.             }
{ This feature is very powerfull and enable the FTP protocol to be used to  }
{ retrieve any kind of data. It this sample, we just check for C:\VIRTUAL   }
{ directory. If this directory is curent, then a TMemoryStream is created   }
{ on the fly with some data. If another directory is selected, the FTP      }
{ server works as any other: just send the requested file, if it exist !    }
{ This event handler is also a place where you can abort the file transfer. }
{ Simply trigger an exception and transfer will not take place.             }
{ Note that if you just wants to prohibe access to some directory or file,  }
{ the best place to code that is in the OnValidateGet or OnValidatePut      }
{ event handlers.                                                           }
procedure TMainForm.FtpServer1RetrSessionConnected(Sender: TObject;
    Client : TFtpCtrlSocket;
    Data   : TWSocket;
    Error  : Word);
var
    Buf : String;
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('[Error] ' + Client.GetPeerAddr +
                           ' Data session connected. Error #' + IntToStr(Error))
    else if Copy(UpperCase(Client.FilePath), 1, 19) = 'C:\VIRTUAL\FORBIDEN' then
        raise Exception.Create('Access prohibed !')
    else if Copy(UpperCase(Client.FilePath), 1, 11) = 'C:\VIRTUAL\' then begin
        InfoMemo.Lines.Add('VIRTUAL FILE');
        Client.UserData   := 1;        { Remember we created a stream }
        if Assigned(Client.DataStream) then
            Client.DataStream.Destroy; { Prevent memory leaks         }
        Client.DataStream := TMemoryStream.Create;
        Buf := 'This is a file created on the fly by the FTP server' + #13#10 +
               'It could result of a query to a database or anything else.' + #13#10 +
               'The request was: ''' + Client.FilePath + '''' + #13#10;
        Client.DataStream.Write(Buf[1], Length(Buf));
        Client.DataStream.Seek(0, 0);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1RetrSessionClosed(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('[Error] ' + Client.GetPeerAddr +
                           ' Data session closed. Error #' + IntToStr(Error));
    if Client.UserData = 1 then begin
        { We created a stream for a virtual file or dir. Delete the TStream }
        if Assigned(Client.DataStream) then begin
            { There is no reason why we should not come here, but who knows ? }
            Client.DataStream.Destroy;
            Client.DataStream := nil;
        end;
        Client.UserData   := 0;     { Reset the flag }
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is called when the FTP component needs to build a      }
{ directory listing. You can just return without doing anything then the    }
{ component will build the directory for you, based on the actual disk      }
{ content. But you can also build your own directory listing with anything  }
{ you like in it. Just create a stream with the required content. The       }
{ example below construct a virtual directory when the user is on the       }
{ C:\VIRTUAL subdirectory (use elsewhere in this sample program).           }
procedure TMainForm.FtpServer1BuildDirectory(
    Sender        : TObject;
    Client        : TFtpCtrlSocket;
    var Directory : TFtpString;
    Detailed      : Boolean);
var
    Buf : String;
begin
    if UpperCase(Client.Directory) <> 'C:\VIRTUAL\' then
        Exit;
    InfoMemo.Lines.Add('VIRTUAL DIR');
    Client.UserData   := 1;        { Remember we created a stream }
    if Assigned(Client.DataStream) then
        Client.DataStream.Destroy; { Prevent memory leaks         }
    Client.DataStream := TMemoryStream.Create;
    if Detailed then
        { We need to format directory lines according to the Unix standard }
        Buf :=
      '-rwxrwxrwx   1 ftp      ftp            0 Apr 30 19:00 FORBIDEN' + #13#10 +
      '-rwxrwxrwx   1 ftp      ftp            0 Apr 30 19:00 TEST' + #13#10 +
      'drwxrwxrwx   1 ftp      ftp            0 Apr 30 19:00 SOME DIR' + #13#10
    else
        Buf := 'FORBIDEN' + #13#10 +
               'TEST' + #13#10;
    Client.DataStream.Write(Buf[1], Length(Buf));
    Client.DataStream.Seek(0, 0);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is called by the FTP component once it has built the   }
{ directory listing. We can use this handler to alter the listing, adding   }
{ or removing some info. This sample add the 'virtual' directory.           }
procedure TMainForm.FtpServer1AlterDirectory(
    Sender        : TObject;
    Client        : TFtpCtrlSocket;
    var Directory : TFtpString;
    Detailed      : Boolean);
var
    Buf : String;
begin
    if UpperCase(Client.Directory) <> 'C:\' then
        Exit;
    { Add our 'virtual' directory to the list }
    if Detailed then begin
        { We need to format directory lines according to the Unix standard }
        Buf :=
        'drwxrwxrwx   1 ftp      ftp            0 Apr 30 19:00 VIRTUAL' + #13#10;
        Client.DataStream.Write(Buf[1], Length(Buf));
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1ClientCommand(Sender: TObject;
  Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
begin
    InfoMemo.Lines.Add('[<<<<] ' + Client.GetPeerAddr + ' ' +
                       Keyword + ' ' + Params);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1AnswerToClient(Sender: TObject;
  Client: TFtpCtrlSocket; var Answer: TFtpString);
begin
    InfoMemo.Lines.Add('[>>>>] ' + Client.GetPeerAddr + ' ' + Answer)
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1Authenticate(Sender: TObject;
  Client: TFtpCtrlSocket; UserName, Password: TFtpString;
  var Authenticated: Boolean);
var
  i: Integer;
begin
    { You should place here the code needed to authenticate the user. }
    { For example a text file with all permitted username/password.   }
    { If the user can't be authenticated, just set Authenticated to   }
    { false before returning.                                         }
    { It is also the right place to setup Client.HomeDir              }
    { If you need to store info about the client for later processing }
    { you can use Client.UserData to store a pointer to an object or  }
    { a record with the needed info.                                  }
    InfoMemo.Lines.Add('[Info] ' + Client.GetPeerAddr +
                       ' User ''' + UserName + ''' is authenticated');
{    if Password = 'bad' then
        Authenticated := FALSE; }
    for i:=0 to FTPServer1.ClientCount-1 do begin
       if FTPServer1.Client[i].UserName=UserName then begin
              Break;
             end;
    end;
    FTPServer1.Client[i].HomeDir:='d:\'+UserName;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FtpServer1ChangeDirectory(Sender: TObject;
  Client: TFtpCtrlSocket; Directory: TFtpString; var Allowed: Boolean);
begin