又一ftp服务器源码

 

源码：
unit ServiceMainU;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
  IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer, Registry, forms,
  IdUserAccounts, IdThreadMgr, IdThreadMgrPool, IdThreadMgrDefault, IdFTPList;

type
  TServMain = class(TService)
    IdFTPServ: TIdFTPServer;
    IdUserMan: TIdUserManager;
    procedure ServiceAfterInstall(Sender: TService);
    procedure ServiceAfterUninstall(Sender: TService);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure ServiceExecute(Sender: TService);
    procedure IdFTPServAfterUserLogin(ASender: TIdFTPServerThread);
    procedure IdFTPServException(AThread: TIdPeerThread;
      AException: Exception);
    procedure IdFTPServRetrieveFile(ASender: TIdFTPServerThread;
      const AFileName: String; var VStream: TStream);
    procedure IdFTPServChangeDirectory(ASender: TIdFTPServerThread;
      var VDirectory: String);
    procedure IdFTPServListDirectory(ASender: TIdFTPServerThread;
      const APath: String; ADirectoryListing: TIdFTPListItems);
    procedure IdFTPServBeforeCommandHandler(ASender: TIdTCPServer;
      const AData: String; AThread: TIdPeerThread);
    procedure IdFTPServGetCustomListFormat(ASender: TIdFTPServer;
      AItem: TIdFTPListItem; var VText: String);
    procedure IdFTPServMakeDirectory(ASender: TIdFTPServerThread;
      var VDirectory: String);
    procedure IdFTPServUserLogin(ASender: TIdFTPServerThread;
      const AUsername, APassword: String; var AAuthenticated: Boolean);
    procedure IdFTPServStoreFile(ASender: TIdFTPServerThread;
      const AFileName: String; AAppend: Boolean; var VStream: TStream);
  private
    { Private declarations }
  public
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  ServMain: TServMain;

const
  csRegEventLog = 'SYSTEM/CurrentControlSet/Services/Eventlog/Application';
  csServiceName = 'ServMain';

implementation

uses MainU;

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  ServMain.Controller(CtrlCode);
end;

function TServMain.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

Procedure RegEventLog( aRegister : Boolean );
Var
  reg : TRegistry;
Begin
  reg := TRegistry.Create;
  Try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    If (reg.OpenKey(csRegEventLog, false)) Then
    Begin
      If (aRegister) Then
      Begin
        If (reg.OpenKey(csServiceName, true)) Then
        Begin
          reg.WriteString('EventMessageFile', ParamStr(0));
          reg.WriteInteger('TypesSupported', EVENTLOG_ERROR_TYPE
                        OR EVENTLOG_WARNING_TYPE OR EVENTLOG_INFORMATION_TYPE);
        End;
      End
      Else
        reg.DeleteKey(csServiceName);
    End;
  Finally
    reg.Free;
  End;
End;

procedure TServMain.ServiceAfterInstall(Sender: TService);
begin
  RegEventLog(true);
end;

procedure TServMain.ServiceAfterUninstall(Sender: TService);
begin
  RegEventLog(false);
end;

procedure TServMain.ServiceStart(Sender: TService; var Started: Boolean);
begin
  IdFTPServ.Active := true;//服务启动
  Started := true;
end;

procedure TServMain.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  IdFTPServ.Active := false;//服务停止
  Stopped := true;
end;

procedure TServMain.ServiceExecute(Sender: TService);
begin
  while not Terminated do//服务响应消息
    begin
      ServiceThread.ProcessRequests(False);
      sleep(100);
    end;
end;

procedure TServMain.IdFTPServAfterUserLogin(ASender: TIdFTPServerThread);
begin
end;

procedure TServMain.IdFTPServException(AThread: TIdPeerThread;
  AException: Exception);
begin
//出错处理，以解决
end;

procedure TServMain.IdFTPServRetrieveFile(ASender: TIdFTPServerThread;
  const AFileName: String; var VStream: TStream);
begin//文件下载，响应Get，以解决
  VStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
end;

procedure TServMain.IdFTPServChangeDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
begin//改变路径，以解决
  if VDirectory[1] = '/' then
    VDirectory := 'E:/ftproot' + VDirectory;
  if pos(VDirectory, 'E:/ftproot/') <> 0 then
    VDirectory := 'E:/ftproot';
end;

procedure TServMain.IdFTPServListDirectory(ASender: TIdFTPServerThread;
  const APath: String; ADirectoryListing: TIdFTPListItems);
begin
end;

procedure TServMain.IdFTPServBeforeCommandHandler(ASender: TIdTCPServer;
  const AData: String; AThread: TIdPeerThread);
begin

end;

procedure TServMain.IdFTPServGetCustomListFormat(ASender: TIdFTPServer;
  AItem: TIdFTPListItem; var VText: String);
begin

end;

procedure TServMain.IdFTPServMakeDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
begin//创建新路经，以解决
  VDirectory := StringReplace(VDirectory, '/', '/', [rfReplaceAll, rfIgnoreCase]);
  ForceDirectories(VDirectory);
end;

procedure TServMain.IdFTPServUserLogin(ASender: TIdFTPServerThread;
  const AUsername, APassword: String; var AAuthenticated: Boolean);
begin
  AAuthenticated := true;//用户登录验证，已实现
end;

procedure TServMain.IdFTPServStoreFile(ASender: TIdFTPServerThread;
  const AFileName: String; AAppend: Boolean; var VStream: TStream);
var//上传文件，终于解决
  hd: integer;
begin
  hd := filecreate(AFileName);
  fileclose(hd);
  VStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyNone);
end;

end;

end.