Пишу в браузере
Сделал всё как в примере Indy, но не работает...
Вот код сервера
Ссылка скрыта от гостей
, а сервер выдаёт ошибку "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.