优化有关代理程序的delphi代码

有高手在吗，看能不能优化有关代理程序的delphi代码
总是有卡顿现象，请帮优化
代码太多，3贴竟然贴不完！
坐等有人回复再贴了

解决方案 »

  1.   

    unit main;interfaceuses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs,SyncObjs,ExtCtrls,StdCtrls, ComCtrls, ActnList, ToolWin, ImgList, Menus,
    IdException,IdBaseComponent, IdComponent, IdTCPServer,IdTCPClient,
    IdURI, IdIOHandlerSocket,IdStack,IdGlobal, IdIntercept,
    IdThreadMgr, IdThreadMgrPool, IdAntiFreezeBase,
    IdAntiFreeze, IdLogBase, IdUserAccounts,IdCoderMIME,
    IdAuthentication,IdIOHandler,IdIOHandlerThrottle, IdSocks,
    IdTCPConnection,IdCustomHTTPServer, IdSocketHandle,IdResourceStrings,
    CheckLst, Buttons, Grids, ValEdit;type
    TMyServerInterceptLogBase = class;
    TIdOnLogString=procedure (ASender: TMyServerInterceptLogBase;Remote:string;ConnectTime:string;Options:String;AData: string) of object;TMyServerInterceptLogBase = class(TIdServerIntercept)
    protected
    FOnLogString:TIdOnLogString;
    FLock: TCriticalSection;
    FLogTime: Boolean;
    FReplaceCRLF: Boolean;
    FActive:boolean;
    public
    procedure Init; override;
    function Accept(AConnection: TComponent): TIdConnectionIntercept; override;
    destructor Destroy;override;
    procedure DoLogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);virtual;
    procedure LogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);virtual;
    public
    constructor Create(AOwner: TComponent); override;
    published
    property Active: Boolean read FActive write FActive default False;
    property LogTime: Boolean read FLogTime write FLogTime default True;
    property ReplaceCRLF: Boolean read FReplaceCRLF write FReplaceCRLF default true;
    end;TMyServerInterceptLogConnection = class(TIdLogBase) //BGO: i just love long class names <g>
    protected
    FServerInterceptLog:TMyServerInterceptLogBase;
    procedure LogReceivedData(const AText: string; const AData: string);override;
    procedure LogSentData(const AText: string; const AData: string); override;
    procedure LogStatus(const AText: string); override;
    function GetConnectionID:string;virtual;end;TMain_form = class(TForm)
    ProxyServer: TIdTCPServer;
    AntiFreeze: TIdAntiFreeze;
    ThreadPool: TIdThreadMgrPool;
    ImageList: TImageList;
    ActionList: TActionList;
    ToolBar: TToolBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton4: TToolButton;
    Action_Start: TAction;
    Action_Stop: TAction;
    Action_Quit: TAction;
    StatusBar: TStatusBar;
    UserManager: TIdUserManager;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    Action_LoadServerInfo: TAction;
    Action_LoadAccount: TAction;
    PopupMenu: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    ToolButton7: TToolButton;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    N7: TMenuItem;
    ToolButton8: TToolButton;
    Action_Intercept: TAction;
    ToolButton9: TToolButton;
    ToolButton10: TToolButton;
    ToolButton11: TToolButton;
    ToolButton3: TToolButton;
    ToolButton12: TToolButton;
    ToolButton13: TToolButton;
    Action_About: TAction;
    ToolButton14: TToolButton;
    Action_Change: TAction;
    PageControl: TPageControl;
    TabSheet1: TTabSheet;
    ClientQuery: TMemo;
    TabSheet4: TTabSheet;
    ChangeList: TValueListEditor;
    ConnectList: TCheckListBox;
    Splitter1: TSplitter;
    Panel1: TPanel;
    SpeedButton1: TSpeedButton;
    ToolButton15: TToolButton;
    procedure ProxyServerGETCommand(ASender: TIdCommand);
    procedure ProxyServerCONNECTCommand(ASender: TIdCommand);
    procedure Action_StartExecute(Sender: TObject);
    procedure Action_StopExecute(Sender: TObject);
    procedure Action_QuitExecute(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Action_LoadServerInfoExecute(Sender: TObject);
    procedure Action_LoadAccountExecute(Sender: TObject);
    procedure Action_StartUpdate(Sender: TObject);
    procedure Action_StopUpdate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ProxyServerNoCommandHandler(ASender: TIdTCPServer;
    const AData: String; AThread: TIdPeerThread);
    procedure Action_InterceptUpdate(Sender: TObject);
    procedure Action_InterceptExecute(Sender: TObject);
    procedure ProxyServerException(AThread: TIdPeerThread;
    AException: Exception);
    procedure Action_AboutExecute(Sender: TObject);
    procedure Action_ChangeExecute(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    private
    { Private declarations }
    public
    { Public declarations }
    function LoadServerInfo(filename:string):boolean;
    procedure SaveServerInfo(filename:string);
    function LoadUserInfo(filename:string):boolean;
    procedure SaveUserInfo(filename:string);
    function LoadChangeList(filename:string):boolean;
    procedure SaveChangeList(filename:string);
    procedure LogString(ASender: TMyServerInterceptLogBase;Remote:string;ConnectTime:string;Options:String;AData: string);
    end;
    procedure SendResponse(AThread:TIdPeerThread;RespNo:integer;Rawstr:string;Content:string;disconnect:boolean);
    procedure ReadHeaders(LConnection:TIdTCPConnection;Headers:TStringList);
    function Auther(Command:TIdCommand;Headers:TStringList;UserManager:TIdUserManager;var LoginUser:TIdUserAccount):boolean;
    procedure ConnectionSet(LPeer:TIdTCPConnection;var Account:TIdUserAccount);
    procedure CreateConnect(Command:TIdCommand;Headers:TStringList;var LClient:TIdTCPConnection);
    procedure SendHeaders(LConnection:TIdTCPConnection;Headers:TStringList;Change:boolean);
    procedure SendData(AThread:TIdPeerThread;LFrom:TIdTCPConnection;LTo:TIdTCPConnection;LSize:integer;Change:boolean);
    procedure TransData(AThread:TIdPeerThread;LFrom:TIdTCPConnection;LTo:TIdTCPConnection;Change:boolean);
    function ChangeData(S:string):string;var
    Main_form: TMain_form;
    ServerInfo,ChangeInfo:TStringList;
    implementation{$R *.dfm}
      

  2.   

    {}
    function TMyServerInterceptLogBase.Accept( AConnection: TComponent): TIdConnectionIntercept;
    begin
       Result:=TMyServerInterceptLogConnection.Create(AConnection);
       TMyServerInterceptLogConnection(Result).FServerInterceptLog:=self;
       TMyServerInterceptLogConnection(Result).LogTime:=FLogTime;
       TMyServerInterceptLogConnection(Result).ReplaceCRLF:=FReplaceCRLF;
       TMyServerInterceptLogConnection(Result).Active:=true;
       TMyServerInterceptLogConnection(Result).FConnection:=AConnection;
       TMyServerInterceptLogConnection(Result).Connect(AConnection);
    end;{}
    constructor TMyServerInterceptLogBase.Create(Aowner:TComponent);
    begin
      Inherited;
      FReplaceCRLF:=true;
      FLogTime:=true;
      FLock := TCriticalSection.Create;
    end;{}
    destructor TMyServerInterceptLogBase.Destroy;
    begin
      FreeAndNil(FLock);
      inherited;
    end;{}
    procedure TMyServerInterceptLogBase.Init;
    begin
    end;{}
    procedure TMyServerInterceptLogBase.LogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);
    begin
    // if (Length(AData) > 0) then begin
          FLock.Enter;
          try
             DoLogWriteString(Remote,ConnectTime,Options,AData);
          finally
            FLock.Leave;
          end;
    // end;
    end;{}
    procedure TMyServerInterceptLogBase.DoLogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);
    begin
      if Assigned(FOnLogString) and FActive then begin
          FOnLogString(Self,Remote,ConnectTime,Options,AData);
      end;
    end;{ TMyServerInterceptLogConnection }
    {}
    procedure TMyServerInterceptLogConnection.LogReceivedData(const AText:string;const AData: string);
    begin
       FServerInterceptLog.LogWriteString(GetConnectionID,AText,'R',AData); {Do not translate}
    end;{}
    procedure TMyServerInterceptLogConnection.LogSentData(const AText: string; const AData: string);
    begin
       FServerInterceptLog.LogWriteString(GetConnectionID,AText,'S',AData); {Do not translate}
    end;{}
    procedure TMyServerInterceptLogConnection.LogStatus(const AText: string);
    var
    Options:String;
    begin
      if AnsiSameText(Atext,RSLogConnected) then begin
         Options:='C';
      end else begin
         if AnsiSameText(AText,RSLogDisconnected) then begin
             Options:='D';
         end else begin
             Options:=AText;
         end;
      end;
      FServerInterceptLog.LogWriteString(GetConnectionID,DateTimeToStr(Now),Options,''); {Do not translate}
    end;{}
    function TMyServerInterceptLogConnection.GetConnectionID:string;
    var
    LSocket: TIdIOHandlerSocket;
    begin
       if (FConnection is TIdTCPConnection) then begin
           LSocket := TIdTCPConnection(FConnection).Socket;
           if (LSocket <> nil) then begin
                if (LSocket.Binding <> nil) then begin
                     with LSocket.Binding do begin
                       Result := PeerIP + ':' + IntToStr(PeerPort);
                     end;
                     Exit;
                end;
           end;
       end;
       Result := '0.0.0.0:0';
    end;{认证}
    function Auther(Command:TIdCommand; Headers:TStringList;UserManager:TIdUserManager;var LoginUser:TIdUserAccount):boolean;
    var
    AuthString,AuthUser,AuthPassword:string;
    LConnection:TIdTCPServerConnection;
    LPeerThread:TIdPeerThread;
    begin
        Result:=strtointdef(ServerInfo.Values['UserManager'],0)<=0;
        LPeerThread:=Command.Thread;
        LConnection:=Command.Thread.Connection;
        if Assigned(LPeerThread) and Assigned(LConnection) then begin//如果需要代理身份认证
               if LConnection.Connected and (not Result) then begin
                     AuthString:=Headers.Values['Proxy-Authorization'];
                     Fetch(AuthString,'Basic',true);
                     AuthString := TIdDecoderMIME.DecodeString(trim(AuthString));//解码用户名和密码
                     if length(trim(AuthString))>0 then begin
                           Headers.Delete(Headers.IndexOfName('Proxy-Authorization'));
                     end;
                     AuthUser:=Fetch(AuthString, ':');
                     AuthPassword:=AuthString;
                     if UserManager.AuthenticateUser(AuthUser,AuthPassword) then begin
                           LoginUser:=UserManager.Accounts[AuthUser];
                           result:=Assigned(LoginUser);
                     end; //if Authentcateuser
               end;
        end;//if usermanager.tag>0
    end;{}
    function ChangeData(S:string):string;
    var
    temp:integer;
    begin
      result:=s;
      try
           for temp:=0 to ChangeInfo.Count-1 do begin
                result:=StringReplace(result,ChangeInfo.Names[temp],ChangeInfo.ValueFromIndex[temp],[rfReplaceAll]);
           end;
      except
      end;
    end;
      

  3.   

    {-------------------------}
    procedure ConnectionSet(LPeer:TIdTCPConnection;var Account:TIdUserAccount);
    var
    LIOHandler:TIdIOHandlerThrottle;
    N:integer;
    begin
       if Assigned(Account) and Assigned(LPeer) then begin
              if LPeer.Connected and (LPeer.IOHandler is TIdIOHandlerThrottle) then begin
                     N:=strtointdef(Account.Attributes.Values['Speed'],0);//设置该用户每连接的流量
                     if N<=0 then begin
                           N:=strtointdef(ServerInfo.Values['SpeedWithPeer'],0);//设置该用户每连接的流量
                     end;
                     if N>0 then begin
                           LIOHandler:=TIdIOHandlerThrottle(LPeer.IOHandler);//建立用于控制每连接流量的对象
                           LIOHandler.BytesPerSec:=N;
                     end;
              end;
       end;
    end;{}
    procedure CreateConnect(Command:TIdCommand;Headers:TStringList;var LClient:TIdTCPConnection);
    var
    LURI: TIdURI;
    LDocument: string;
    ProxyString,ProxyAuth:String;
    LAuth:TIdBasicAuthentication;
    LPeer:TIdTCPConnection;
    LThread:TIdPeerThread;
    LHost:string;
    LVersion:string;
    LSocksInfo:TIdSocksInfo;
    LIOHandler:TIdIOHandlerThrottle;
    begin
         LThread:=Command.Thread;
         LPeer:=Command.Thread.Connection;
         if (not Assigned(Command)) or (not Assigned(LThread))
             or (not Assigned(LPeer)) or (not Assigned(Headers)) then begin
                 exit;
         end else begin
                 if not (Command.Params.Count=2) then begin
                     exit;
                 end;
         end;
         if LPeer.Connected and (not LThread.Stopped) then begin
                 LClient:=TIdTCPClient.Create(nil);
                 LIOHandler:=TIdIOHandlerThrottle.Create(LClient);
                 LClient.IOHandler:=TIdIOHandlerSocket.Create(LIOHandler);
                 LIOHandler.ChainedHandler:=LClient.IOHandler;
                 LClient.IOHandler:=LIOHandler;
                 LClient.ReadTimeout:=strtointdef(ServerInfo.Values['ReadTimeOut'],0);
                 LClient.ReadTimeout:=iif(LClient.ReadTimeout=-1,0,LClient.ReadTimeout);
                 LURI := TIdURI.Create(Command.Params.Strings[0]); //建立一个分析URL的对象
                 LVersion:=Command.Params.Strings[1];
                 if AnsiSameText(Command.CommandHandler.Command,'CONNECT')
                      and (LURI.Protocol='') then begin//如果是connect命令，并且url中没有http协议字符，则添加后进行分析
                           LURI.URI:='HTTP://'+Command.Params.Strings[0];
                 end;
                 if not AnsiSameText(Command.CommandHandler.Command,'OPTIONS') then begin
                        if LURI.Host='' then begin
                              exit;//如果不是options命令，不能从url中分析出目标主机则认为此请求是无效的http代理请求
                        end;
                 end else begin  //如果是options命令，则通过host字段来分析目标主机
                        LHost:=Headers.Values['Host'];
                        LURI.Host:=Fetch(LHost,':',true);
                        LURI.Port:=LHost;
                 end;
                 try
                        TIdTCPClient(LClient).Port := StrToIntDef(LURI.Port, 80);//获取请求url中的端口信息
                        TIdTCPClient(LClient).Host := LURI.Host;
                        LDocument := LURI.Path + LURI.Document + LURI.Params;//重建资源路径（使用相对路径的表示方式）
                        if LURI.Book<>'' then begin
                               LDocument:=LDocument+'#'+LURI.Book;
                        end;
                        LURI.URI:='';
                        ProxyString:=Serverinfo.Values[TIdTCPClient(LClient).Host+':'+
                        IntToStr(TIdTCPClient(LClient).Port)];//根据系统配置，设置二级代理
                        if Length(Trim(ProxyString))>0 then begin
                                LURI.URI:=ProxyString;
                                if AnsiSameText(LURI.Protocol,'HTTP') then begin//如果使用http二级代理
                                       if not LClient.Connected then begin
                                               TIdTCPClient(LClient).Port:=StrToIntDef(LURI.Port, 8080);
                                               TIdTCPClient(LClient).Host := LURI.Host;
                                        end;
                                        if LURI.Username<>'' then begin //如果二级需要验证身份，则重新修改代理认证字段
                                              LAuth := TIdBasicAuthentication.Create;
                                              try
                                                    with LAuth do begin
                                                           Params.Values['Username'] := LURI.Username;
                                                           Params.Values['Password'] := LURI.Password;
                                                           ProxyAuth:= Authentication;
                                                    end;
                                                    if Length(ProxyAuth)>0 then begin
                                                          Headers.Values['Proxy-Authorization']:= ProxyAuth;
                                                    end;
                                              finally
                                                    LAuth.Free;
                                              end;
                                         end;                             end else begin //如果使用socks代理
                                         LSocksInfo:=LClient.Socket.SocksInfo;
                                         with LSocksInfo do begin
                                                IoHandler:=LClient.IOHandler;
                                                Username:=LURI.Username;
                                                Password:=LURI.Password;
                                                if not LClient.Connected then begin
                                                      Host:=LURI.Host;
                                                      Port:=strtointdef(LURI.Port,1080);
                                                end;//设置二级代理的类型 0=无socks代理 1=SOCKS4 2=SOCKS4A 3=SOCKS5
                                                Version:=TSocksVersion(
                                                     iif(AnsiSameText(LURI.Protocol,'SOCKS4'),1,
                                                     iif(AnsiSameText(LURI.Protocol,'SOCKS4A'),2,
                                                     iif(AnsiSameText(LURI.Protocol,'SOCKS5'),3,0))));
                                                     //根据二级socks代理是否需要身份验证，//只有socks5支持身份认证
                                                Authentication:=TSocksAuthentication(
                                                     iif(trim(UserName)<>'',1,0));
                                         end;
                                 end;
                       end else begin //如果没有定义该目标主机的二级代理，则修改请求命令行
                                 Headers.Strings[0]:=Command.CommandHandler.Command+' '+
                                 LDocument+' '+LVersion;
                       end; //length(ProxyString)>0
             if Headers.Values['Proxy-Connection']<>'' then begin
                       Headers.Delete(Headers.IndexOfName('Proxy-Connection'));//删除请求包中的代理标志
             end;
         finally
             FreeAndNil(LURI);
         end;
         try
            TIdTCPClient(LClient).Connect(strtointdef(ServerInfo.Values['ConnectTimeOut'],10000));
         except
            on E:EIdConnectTimeout do begin
               SendResponse(LThread,504,'','连接目标主机超时',true);
            end;
         end;
       end;
    end;{}
    procedure ReadHeaders(LConnection:TIdTCPConnection;Headers:TStringList);
    begin
      if Assigned(LConnection) and Assigned(Headers) then begin
           if LConnection.Connected then begin
                LConnection.Capture(Headers,'');
           end;
       end;
    end;procedure SendData(Athread:TIdPeerThread;LFrom:TIdTCPConnection;
    LTo:TIdTCPConnection;LSize:integer;Change:boolean);
    var
    LContentSize:integer;
    Temp:integer;
    TempStr:string;
    begin
      if not Assigned(AThread) or not Assigned(LFrom) or  not Assigned(LTo) then begin
          exit;
      end;
      LContentSize:=LSize;
      case Lsize of
          -1:begin
                 exit;
             end;
          0:begin
                 while (LFrom.Connected) and (LTO.Connected) do begin
                       try
                            LFrom.ReadFromStack(false,LFrom.ReadTimeout,false);
                       except
                       end;
                       if LFrom.InputBuffer.Size>0 then begin
                            LFrom.InputBuffer.Seek(0,soFromBeginning);
                            try
                                  LTo.WriteBuffer(LFrom.InputBuffer.memory^,LFrom.InputBuffer.Size);
                            finally
                                  LFrom.InputBuffer.Remove(LFrom.InputBuffer.Size);
                            end;
                       end;
                       LFrom.CheckForGracefulDisconnect(false);
                       LTo.CheckForGracefulDisconnect(false);
                 end;
             end;
          else begin
                 while (LContentSize>0) and (LFrom.Connected) and (LTo.Connected) do begin
                        try
                              LFrom.ReadFromStack(false,LFrom.ReadTimeout,false);
                        except
                        end;
                        Temp:=LFrom.InputBuffer.Size;
                        if Temp>0 then begin
                               try
                                    if Change then begin
                                          TempStr:=ChangeData(LFrom.InputBuffer.Extract(Temp));
                                          LTo.Write(TempStr);
                                    end else begin
                                          LTo.WriteBuffer(LFrom.InputBuffer.memory^,Temp);
                                          LFrom.InputBuffer.Remove(Temp);
                                    end;
                               finally
                                    Dec(LContentSize,Temp);
                               end;
                        end;
                        LFrom.CheckForGracefulDisconnect(false);
                        LTo.CheckForGracefulDisconnect(false);
                 end;
          end;
      end;
    end;