server_module.pas

Delphi快速开发Web Server

unit Server_Module;

interface

uses
  SysUtils, Classes, IniFiles,

  Forms,

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

  rtcFileProvider,
  rtcPHPProvider,
  rtcISAPIProvider,
  rtcMessengerProvider;

type
  TData_Server = class(TDataModule)
    Server: TRtcHttpServer;

    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 UnloadIsapi;

    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
  Data_Server: TData_Server;

implementation

{$R *.dfm}

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

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

procedure TData_Server.Start;
  var
    a:integer;

    IniName:string;
    Ini:TCustomIniFile;
    SL:TStringList;

    web_usePHP,
    web_useMSG:boolean;

  begin
  IniName := ChangeFileExt(AppFileName, '.ini');

  XLog('Read LOG "'+IniName+'"');

  SL := TStringList.Create;
  try

    Ini := TIniFile.Create(IniName);
    try
      web_UsePHP := (Ini.ReadString('PHP','Enable','') = '1');

      if web_UsePHP then
        begin
        with GetPHPProvider do
          begin
          DllFolder:= Ini.ReadString('PHP','DllFolder','');
          IniFolder := Ini.ReadString('PHP','IniFolder','');

          ClearExts;
          AddExts( Ini.ReadString('PHP','Extensions','') );
          end;
        end;

      with GetISAPIProvider do
        begin
        ClearExts;
        AddExts( Ini.ReadString('ISAPI','Extensions','') );
        end;

      web_UseMsg := (Ini.ReadString('Messenger','Enable', '') = '1');
    finally
      Ini.Free;
      end;

    Ini := TMemIniFile.Create(IniName);
    try
      with GetFileProvider do
        begin
        ClearHosts;
        SL.Clear;
        Ini.ReadSectionValues('Hosts',SL);
        for a:=0 to SL.Count-1 do
          AddHost(SL[a]);

        ClearIndexPages;
        SL.Clear;
        Ini.ReadSectionValues('Index Pages',SL);
        for a:=0 to SL.Count-1 do
          AddIndexPage(SL[a]);

        ClearContentTypes;
        SL.Clear;
        Ini.ReadSectionValues('Content Types',SL);
        for a:=0 to SL.Count-1 do
          AddContentType(SL[a]);
        end;
    finally
      Ini.Free;
      end;
  finally
    SL.Free;
    end;

  // Assign our Server to Data Providers
  GetFileProvider.ServerLink.Server:=Server;
  GetISAPIProvider.ServerLink.Server:=Server;
  if web_usephp then
    GetPHPProvider.ServerLink.Server:=Server;
  if web_usemsg then
    GetMessengerProvider.ServerLink.Server:=Server;

  // Start DataServer
  Server.Listen;
  end;

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

procedure TData_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 TData_Server.ServerListenStart(Sender: TRtcConnection);
  begin
  XLog('SERVER STARTED ...');
  if assigned(OnStart) then
    OnStart(Sender);
  end;

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

procedure TData_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 TData_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 TData_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 TData_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 TData_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 TData_Server.GetClientCount: integer;
  begin
  CS.Enter;
  try
    Result:=CliCnt;
  finally
    CS.Leave;
    end;
  end;

procedure TData_Server.UnloadIsapi;
  begin
  GetISAPIProvider.UnLoad;
  end;

end.