Форум программистов [Powered by Invision Power Board]

Код

unit uServer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, Menus, ExtCtrls, IdBaseComponent, IdComponent, IdTCPServer,
  IdCustomHTTPServer,IdStream,idStreamVCL, IdHTTPServer, Buttons, IdContext, StdCtrls,
  IdServerIOHandler, IdSSL, IdSSLOpenSSL;

const
  maxConnections = 4;
  clOn = clLime;
  clOff = clGreen;

type
  AShape = array of TShape;

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Panel1: TPanel;
    Panel2: TPanel;
    pServerActive: TPanel;
    Panel4: TPanel;
    TabSheet3: TTabSheet;
    Panel3: TPanel;
    bServerStart: TSpeedButton;
    bServerStop: TSpeedButton;
    Memo1: TMemo;
    IdTCPServer1: TIdTCPServer;
    Memo2: TMemo;
    Memo3: TMemo;
    IdServerIOHandlerSSLOpenSSL: TIdServerIOHandlerSSLOpenSSL;
    Timer1: TTimer;
    ledListening: TShape;
    procedure ledListeningContextPopup(Sender: TObject; MousePos: TPoint;
      var Handled: Boolean);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Timer1Timer(Sender: TObject);
    procedure IdServerIOHandlerSSLOpenSSLGetPassword(var Password: string);
    procedure IdTCPServer1Execute(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure bServerStopClick(Sender: TObject);
    procedure bServerStartClick(Sender: TObject);
    procedure OnTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
     ledConnected: AShape;
  public
    { Public declarations }
  end;

type
  THTTPInfoSpec = record
    Active: Boolean;
  end;

  THTTPInfo = record
    Spec: THTTPInfoSpec;
    Server: String[255];
  end;


var
  Form1: TForm1;
  Timer: TTimer;
  HTTPInfo: THTTPInfo;
  idTCPserver2: TIdContext;

implementation

uses uServer2;

{$R *.dfm}


{Процедура таймера "OnTimer"}
procedure TForm1.OnTimer(Sender: TObject);
begin
  Timer.Enabled := False;


  Timer.Enabled := True;
end;

{ Создание формы }
procedure TForm1.FormCreate(Sender: TObject);
var
  i, x: integer;
  appDir: string;
begin
  left:= 580;
  top:= 80;

  IdTCPServer1.MaxConnections:= maxConnections;

  { IMPORTANT!  You must specify the certificate, key, and root cert files! }
  appDir:= extractFilePath(application.exename);
  IdServerIOHandlerSSLOpenSSL.SSLOptions.KeyFile:= appDir + 'sample.key';
  IdServerIOHandlerSSLOpenSSL.SSLOptions.CertFile:= appDir + 'sample.crt';
  IdServerIOHandlerSSLOpenSSL.SSLOptions.RootCertFile:= appDir + 'sampleRoot.pem';

  setLength(ledConnected,maxConnections);

  x:= 225;
  for i:= 0 to (maxConnections - 1) do begin
    ledConnected[i]:= TShape.create(panel1);
    with ledConnected[i] do begin
      parent:= panel1;
      height:= 8;
      width:= 20;
      top:= 15;
      left:= x;  inc(x,25);
      brush.color:= clOff;
    end; { do with ledConnected[i] }
  end; { for i:= 0 to (maxConnections - 1) }

  timer1.enabled:= true;

end;


{ Старт }
procedure TForm1.bServerStartClick(Sender: TObject);
begin
  idTCPserver1.Active := True;
end;

{ Стоп }
procedure TForm1.bServerStopClick(Sender: TObject);
begin
  //
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
{ THESE TWO LINES ARE CRITICAL TO MAKING THE IdTCPSERVER WORK WITH SSL! }
  if (AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase) then
    TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough:= False;

  Memo1.Lines.Add('connect...');
end;

procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
begin
  Memo1.Lines.Add('disconnect...');
end;

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
  List: TList;
  s, s2, s3, s4, r: AnsiString;
  i: integer;
  c: char;
TempStream: TFileStream;
TempStringList: TIdStreamVCL;
Stream: TIdStream;

begin
  randomize;
  r := IntToStr(random(100));



  try
    List := IdTCPServer1.Contexts.LockList;
    Memo1.Lines.Add('execute...begin...['+IntToStr(List.Count)+'] - '+r);
    IdTCPServer1.Contexts.UnlockList;
  except
  end;

  Memo3.Clear;

  repeat
    c := AContext.Connection.Socket.ReadChar;
    i := AContext.Connection.Socket.InputBuffer.Size;

    s2 := s2 + c;
  until i = 0;

  Memo1.Lines.Add(s2);

  Memo3.Clear;
  Memo3.Lines.Add('<p>123<p>');

  Memo2.Clear;
  Memo2.Lines.Add('HTTP/1.1 200 OK');
  Memo2.Lines.Add('Server: Apache/2.2.3 (Debian)');
  Memo2.Lines.Add('Keep-Alive: timeout=15, max=100');
  Memo2.Lines.Add('Connection: Keep-Alive');
  Memo2.Lines.Add('Content-Type: text/html; charset=UTF-8');
  Memo2.Lines.Add('Content-Length: '+IntToStr(Length(Memo3.Text)));


  s := Memo2.Text +
       chr(10) +
       Memo3.Text;

  AContext.Connection.Socket.WriteLn(s);
  AContext.Connection.Disconnect;



  Memo1.Lines.Add('execute...end...');

end;

procedure TForm1.IdServerIOHandlerSSLOpenSSLGetPassword(var Password: string);
begin
  password:= 'aaaa';
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  { This approach (with the timer) is used to ensure that *everything* has been fully
    created and the application is running before we start the server up. }
    
  timer1.enabled:= false;
  IdTCPServer1.Active:= true;
  ledListening.Brush.color:= clOn;

end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  idTcpServer1.Active:= false;
  ledListening.Brush.Color:= clOff;
  application.processMessages;
  canClose:= true;
end;

procedure TForm1.ledListeningContextPopup(Sender: TObject; MousePos: TPoint;
  var Handled: Boolean);
begin

end;

end.