ftpserv1.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

    FtpServer1.DisconnectAll;
end;

{退出程序}
procedure TFtpServerForm.MnuQuitClick(Sender: TObject);
begin
    Close;
end;

{停止服务器}
procedure TFtpServerForm.MnuStopServerClick(Sender: TObject);
begin
    StopServer;
end;

{启动服务器}
procedure TFtpServerForm.MnuStartServerClick(Sender: TObject);
begin
    StartServer;
end;


{启动或停止服务器}
procedure TFtpServerForm.ImagesDblClick(Sender: TObject);
begin
    if FtpServer1.Active then
        StopServer
    else
        StartServer;
end;


{更新用户计数}
procedure TFtpServerForm.UpdateClientCount;
begin
    if FtpServer1.ClientCount = 0 then
        ClientCountLabel.Caption := '没有连接'
    else
        ClientCountLabel.Caption := IntToStr(FtpServer1.ClientCount) + ' 连接';
end;


{客户端连接触发}
procedure TFtpServerForm.FtpServer1ClientConnect(Sender: TObject;
  Client: TFtpCtrlSocket; Error: Word);
begin
    {根据IP拒绝访问}
    if Client.GetPeerAddr = '10.11.111.111' then begin
        Client.SendStr('421 Connection not allowed.' + #13#10);
        Client.Close;
        Exit;
    end;
    InfoMemo.Lines.Add('! ' + Client.GetPeerAddr + ' connected');
    UpdateClientCount;
end;


{客户端关闭连接时触发}
procedure TFtpServerForm.FtpServer1ClientDisconnect(Sender: TObject;
  Client: TFtpCtrlSocket; Error: Word);
begin
    InfoMemo.Lines.Add('! ' + Client.GetPeerAddr + ' disconnected');
    UpdateClientCount;
end;


{服务器启动时触发}
procedure TFtpServerForm.FtpServer1Start(Sender: TObject);
begin
    GreenImage.Visible := TRUE;
    RedImage.Visible   := FALSE;
    InfoMemo.Lines.Add('! Server started');
end;


{服务器停止时触发}
procedure TFtpServerForm.FtpServer1Stop(Sender: TObject);
begin
    GreenImage.Visible := FALSE;
    RedImage.Visible   := TRUE;
    InfoMemo.Lines.Add('! Server stopped');
end;


{上载文件连接启动时触发}
procedure TFtpServerForm.FtpServer1StorSessionConnected(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('! ' + Client.GetPeerAddr +
                           ' Data session failed to open. Error #' +
                           IntToStr(Error));
end;


{下载文件连接关闭时触发}
procedure TFtpServerForm.FtpServer1StorSessionClosed(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('! ' + Client.GetPeerAddr +
                           ' Data session closed. Error #' + IntToStr(Error));
end;


{下载文件数据时触发}
procedure TFtpServerForm.FtpServer1RetrDataSent(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('! ' + Client.GetPeerAddr +
                           ' Data sent. Error #' + IntToStr(Error));
end;


{当一个下载文件连接启动时触发该事件，可以在这个事件加入处理代码，决定给客户端返回
什么数据，如果没有指定任何返回数据，服务器可以根据客户端的实际请求返回指定
文件的数据。在本实例中，检查是否请求虚拟目录C:\VIRTUAL中的文件，如果是则返回
一些特殊的数据}
procedure TFtpServerForm.FtpServer1RetrSessionConnected(Sender: TObject;
    Client : TFtpCtrlSocket;
    Data   : TWSocket;
    Error  : Word);
var
    Buf : String;
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('! ' + 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 TFtpServerForm.FtpServer1RetrSessionClosed(Sender: TObject;
  Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
begin
    if Error <> 0 then
        InfoMemo.Lines.Add('! ' + 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;

{ 该事件在服务器响应客户端请求创建文件（目录）列表时 触发，可以在该事件中自定义
返回列表的内容。如果没指定，服务器将根据当前目录搜索文件列表返回给客户端}
procedure TFtpServerForm.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;

{该事件在客户端请求改变当前目录时触发，可以加入自己的代码控制更改目录时
返回给客户端的文件列表，如果没指定，服务器将根据当前目录搜索文件列表返
回给客户端}
procedure TFtpServerForm.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 TFtpServerForm.FtpServer1ClientCommand(Sender: TObject;
  Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
begin
    InfoMemo.Lines.Add('< ' + Client.GetPeerAddr + ' ' +
                       Keyword + ' ' + Params);
                      
end;


{服务器响应客户端请求时触发}
procedure TFtpServerForm.FtpServer1AnswerToClient(Sender: TObject;
  Client: TFtpCtrlSocket; var Answer: TFtpString);
begin
    InfoMemo.Lines.Add('> ' + Client.GetPeerAddr + ' ' + Answer)
end;

{服务器认证时触发，可以在这个事件中加入用于认证的代码，处理授权用户
的连接。同时可以根据不同用户设置FTP起始的根目录不同}
procedure TFtpServerForm.FtpServer1Authenticate(Sender: TObject;
  Client: TFtpCtrlSocket; UserName, Password: TFtpString;
  var Authenticated: Boolean);
begin
    InfoMemo.Lines.Add('! ' + Client.GetPeerAddr +
                       ' User ''' + UserName + ''' is authenticated');
end;

{改变目录时触发}
procedure TFtpServerForm.FtpServer1ChangeDirectory(Sender: TObject;
  Client: TFtpCtrlSocket; Directory: TFtpString; var Allowed: Boolean);
begin
{$IFDEF NEVER}
    { It the right place to check if a user has access to a given directory }
    { The example below disable C:\ access to non root user.                }
    if (UpperCase(Client.UserName) <> 'ROOT') and
       (UpperCase(Client.Directory) = 'C:\') then
       Allowed := FALSE;
{$ENDIF}
end;

{清除日志记录}
procedure TFtpServerForm.Cleardisplay1Click(Sender: TObject);
begin
    InfoMemo.Clear;
end;

end.