http_module.pas

著名的SecureBlackBox控件完整源码

unit HTTP_Module;

interface

uses
  SysUtils, Classes,

  Forms,

  rtcLog, rtcSyncObjs,
  rtcInfo, rtcConn,
  rtcDataSrv, rtcHttpSrv,

  rtcFileProvider, SBX509, SBCustomCertStorage, rtcPlugins,
  SBRTCServerPlugin, SBRTCPlugin;

type
  THTTP_Server = class(TDataModule)
    Server: TRtcHttpServer;
    SSLCrypt: TSSLServerRtcCryptPlugin;
    CertStorage: TElMemoryCertStorage;

    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);

    procedure ServerListenError(Sender: TRtcConnection; E: Exception);
    procedure ServerListenStart(Sender: TRtcConnection);
    procedure ServerListenStop(Sender: TRtcConnection);
    procedure ServerConnecting(Sender: TRtcConnection);
    procedure ServerDisconnecting(Sender: TRtcConnection);
    procedure ServerRequestNotAccepted(Sender: TRtcConnection);
    procedure ServerInvalidRequest(Sender: TRtcConnection);
    procedure ServerDisconnect(Sender: TRtcConnection);
  private
    { Private declarations }
    FOnError: TRtcErrorEvent;
    FOnStart: TRtcNotifyEvent;
    FOnStop: TRtcNotifyEvent;
    FOnConnect: TRtcNotifyEvent;
    FOnDisconnect: TRtcNotifyEvent;

    CS:TRtcCritSec;
    CliCnt:integer;
    function GetClientCount: integer;

  public
    { Public declarations }

    procedure Start;
    procedure Stop;

    property ClientCount:integer read GetClientCount;

    property OnStart:TRtcNotifyEvent read FOnStart write FOnStart;
    property OnStop:TRtcNotifyEvent read FOnStop write FOnStop;
    property OnError:TRtcErrorEvent read FOnError write FOnError;
    property OnConnect:TRtcNotifyEvent read FOnConnect write FOnConnect;
    property OnDisconnect:TRtcNotifyEvent read FOnDisconnect write FOnDisconnect;
  end;

var
  HTTP_Server: THTTP_Server;

implementation

{$R *.dfm}

procedure THTTP_Server.DataModuleCreate(Sender: TObject);
  begin
  CS:=TRtcCritSec.Create;
  CliCnt:=0;
  end;

procedure THTTP_Server.DataModuleDestroy(Sender: TObject);
  begin
  CS.Free;
  end;

procedure THTTP_Server.Start;
  var
    s:string;
    a,i:integer;
    f:TextFile;
  begin
  // Read configuration file ...
  XLog('Read LOG "'+ExpandFileName(AppFileName)+'.cfg"');

  AssignFile(f,AppFileName+'.cfg');
  {$I-}
  Reset(f);
  {$I+}
  if IOResult=0 then
    begin
    try
      with GetFileProvider do
        begin
        ClearIndexPages;
        ReadLn(f, s); s:=Trim(s); i:=StrToIntDef(s,0);
        for a:=0 to i-1 do
          begin
          ReadLn(f, s);
          AddIndexPage(s);
          end;

        ClearHosts;
        ReadLn(f, s); s:=Trim(s); i:=StrToIntDef(s,0);
        for a:=0 to i-1 do
          begin
          ReadLn(f, s);
          AddHost(s);
          end;

        // next 3 lines are for ISAPI support
        for a:=1 to 3 do
          ReadLn(f, s);

        ClearContentTypes;
        ReadLn(f, s); s:=Trim(s); i:=StrToIntDef(s,0);
        for a:=0 to i-1 do
          begin
          ReadLn(f, s);
          AddContentType(s);
          end;
        end;
    except
      // ignore errors while reading the CFG file
      end;
    CloseFile(f);
    end;

  // Assign our Server to Data Providers
  GetFileProvider.ServerLink.Server:=Server;

  // Start DataServer
  Server.Listen;
  end;

procedure THTTP_Server.Stop;
  begin
  Server.StopListen;
  end;

procedure THTTP_Server.ServerListenError(Sender: TRtcConnection; E: Exception);
  begin
  XLog('Error starting Web Server!'#13#10 + E.ClassName+'>'+E.Message);
  if assigned(OnError) then
    OnError(Sender,E);
  end;

procedure THTTP_Server.ServerListenStart(Sender: TRtcConnection);
  begin
  XLog('SERVER STARTED ...');
  if assigned(OnStart) then
    OnStart(Sender);
  end;

procedure THTTP_Server.ServerListenStop(Sender: TRtcConnection);
  begin
  if assigned(OnStop) then
    OnStop(Sender);
  XLog('SERVER STOPPED.');
  end;

procedure THTTP_Server.ServerConnecting(Sender: TRtcConnection);
  begin
  CS.Enter;
  try
    Inc(CliCnt);
    with Sender do
      XLog('++++ '+PeerAddr+':'+PeerPort+' ['+IntToStr(CliCnt)+' open]');
  finally
    CS.Leave;
    end;
  if assigned(OnConnect) then
    OnConnect(Sender);
  end;

procedure THTTP_Server.ServerDisconnecting(Sender: TRtcConnection);
  begin
  CS.Enter;
  try
    Dec(CliCnt);
    with Sender do
      XLog('---- '+PeerAddr+':'+PeerPort+' ['+IntToStr(CliCnt)+' open]');
  finally
    CS.Leave;
    end;
  if assigned(OnDisconnect) then
    OnDisconnect(Sender);
  end;

procedure THTTP_Server.ServerRequestNotAccepted(Sender: TRtcConnection);
  begin
  // Anything that comes this far is not acceptable by any DataProvider component.
  with TRtcDataServer(Sender) do
    begin
    XLog('BAD! '+PeerAddr+' > "'+Request.Method+' '+Request.FileName+'" > Method "'+Request.Method+'" not supported.');

    Response.Status(400,'Bad Request');
    Write('Status 400: Bad Request');
    
    Disconnect;
    end;
  end;

procedure THTTP_Server.ServerInvalidRequest(Sender: TRtcConnection);
  begin
  with TRtcDataServer(Sender) do
    begin
    XLog('ERR! '+PeerAddr+' > "'+Request.Method+' '+Request.FileName+'" > Invalid Request: Header size limit exceeded.');

    Response.Status(400,'Bad Request');
    Write('Status 400: Bad Request');
    end;
  end;

procedure THTTP_Server.ServerDisconnect(Sender: TRtcConnection);
  begin
  with TRtcDataServer(Sender) do
    begin
    if Request.DataSize > Request.DataIn then
      begin
      // did not receive a complete request
      XLog('ERR! '+PeerAddr+' > '+Request.Host+
           ' "'+Request.Method+' '+Request.URI+'"'+
           ' 0'+
           ' REF "'+Request.Referer+'"'+
           ' AGENT "'+Request.Agent+'" '+
           '> DISCONNECTED while receiving a Request ('+IntToStr(Request.DataIn)+' of '+IntToStr(Request.DataSize)+' bytes received).');
      end;
    end;
  end;

function THTTP_Server.GetClientCount: integer;
  begin
  CS.Enter;
  try
    Result:=CliCnt;
  finally
    CS.Leave;
    end;
  end;

end.