Idtcpserver + Ssl (indy 10)

slavon-x86

Well-known member
18.12.2005
215
0
#1
Пишу в браузере http://localhost/, а сервер выдаёт ошибку "Error accepting connection with SSL"
Сделал всё как в примере Indy, но не работает...

Вот код сервера
Код:
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.
 

slavon-x86

Well-known member
18.12.2005
215
0
#3
В эксплорере заработало, а в опере выдаёт всё ту же ошибку !
Может это быть из-за того, что сертификат просроченный ?