cltcpserver.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

  end;
end;

procedure TclTcpServer.ServerError(E: Exception);
begin
  if FIsStart then
  begin
    FStartError := E.Message;
    if (E is EclSocketError) then
    begin
      FStartErrorCode := (E as EclSocketError).ErrorCode;
    end;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'ServerError', E);{$ENDIF}
  DoServerError(E);
end;

procedure TclTcpServer.VerifyClient(Sender: TObject;
  ACertificate: TclCertificate; const AStatusText: string;
  AStatusCode: Integer; var AVerified: Boolean);
var
  ns: TclNetworkStream;
begin
  ns := (Sender as TclNetworkStream);
  DoVerifyClient((ns.Connection as TclCommandConnection), ACertificate, AStatusText, AStatusCode, AVerified);
end;

procedure TclTcpServer.DoVerifyClient(AConnection: TclCommandConnection;
  ACertificate: TclCertificate; const AStatusText: string;
  AStatusCode: Integer; var AVerified: Boolean);
begin
  if Assigned(OnVerifyClient) then
  begin
    OnVerifyClient(Self, AConnection, ACertificate, AStatusText, AStatusCode, AVerified);
  end;
end;

{ TclTcpServerWorkItem }

constructor TclTcpServerWorkItem.Create(AServer: TclTcpServer;
  AConnection: TclCommandConnection; AOperation: TclTcpServerOperation);
begin
  inherited Create();
  FServer := AServer;
  FConnection := AConnection;
  FConnection._AddRef();
  FOperation := AOperation;
end;

destructor TclTcpServerWorkItem.Destroy;
begin
  FConnection._Release();
  inherited Destroy();
end;

procedure TclTcpServerWorkItem.DoRead;
var
  readStream: TStream;
begin
  readStream := TMemoryStream.Create();
  try
    FConnection.BeginWork();
    try
      if FConnection.FIsReading then Exit;
      FConnection.FIsReading := True;
      FConnection.ReadData(readStream);
    finally
      FConnection.FIsReading := False;
      FConnection.EndWork();
    end;
    FServer.DoReadConnection(FConnection, readStream);
  finally
    readStream.Free();
  end;
end;

procedure TclTcpServerWorkItem.DoWrite;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'DoWrite');{$ENDIF}
  FConnection.BeginWork();
  try
    if (FConnection.FWriteStream.Position < FConnection.FWriteStream.Size - 1) then
    begin
      FConnection.WriteData(FConnection.FWriteStream);
    end;
    FServer.DoWriteConnection(FConnection);
  finally
    FConnection.EndWork();
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'DoWrite'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'DoWrite', E); raise; end; end;{$ENDIF}
end;          

procedure TclTcpServerWorkItem.Execute;
begin
  Assert(FServer <> nil);
  try
    FConnection.InitProgress(0, 0);
    case FOperation of
      soServerRead: DoRead();
      soServerWrite: DoWrite();
    end;
  except
    on EAbort do ;
    on E: Exception do
    begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'Execute ServerError', E);{$ENDIF}
      FServer.ServerError(E);
    end;
  end;
end;

function TclTcpServer.GetMaxThreadCount: Integer;
begin
  Result := FWorkerThreadPool.MaxThreadCount;
end;

function TclTcpServer.GetMinThreadCount: Integer;
begin
  Result := FWorkerThreadPool.MinThreadCount;
end;

procedure TclTcpServer.ReadConnection(AConnection: TclCommandConnection);
begin
  if (AConnection = nil) then Exit;
  if not AConnection.FIsReading then
  begin
    FWorkerThreadPool.QueueWorkItem(TclTcpServerWorkItem.Create(Self, AConnection, soServerRead));
  end;
end;

procedure TclTcpServer.WriteConnection(AConnection: TclCommandConnection);
begin
  if (AConnection = nil) then Exit;
  FWorkerThreadPool.QueueWorkItem(TclTcpServerWorkItem.Create(Self, AConnection, soServerWrite));
end;

procedure TclTcpServer.SetMaxThreadCount(const Value: Integer);
begin
  FWorkerThreadPool.MaxThreadCount := Value;
end;

procedure TclTcpServer.SetMinThreadCount(const Value: Integer);
begin
  FWorkerThreadPool.MinThreadCount := Value;
end;

procedure TclTcpServer.Start;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    IsCertDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  if (FServerThread <> nil) then
  begin
    raise EclSocketError.Create(cServerStarted, -1);
  end;

  FIsStart := True;
  try
    FStartError := '';
    FStartErrorCode := 0;

    FServerThread := TclServerThread.Create(Self);
    FServerThread.Start();

    if (FStartError <> '') or (FStartErrorCode <> 0) then
    begin
      InternalStop();

      if (FStartError = '') then
      begin
        FStartError := cStartError;
      end;
      if (FStartErrorCode = 0) then
      begin
        FStartErrorCode := -1;
      end;
      raise EclSocketError.Create(FStartError, FStartErrorCode);
    end;
  finally
    FIsStart := False;
  end;

  DoStart();
end;

procedure TclTcpServer.InternalStop;
begin
  FServerThread.Stop();
  FServerThread.Free();
  FServerThread := nil;
  FWorkerThreadPool.Stop();
end;

procedure TclTcpServer.Stop;
begin
  if (FServerThread = nil) then Exit;
  InternalStop();
  DoStop();
end;

{ TclServerThread }

constructor TclServerThread.Create(AServer: TclTcpServer);
begin
  inherited Create(True);
  FServer := AServer;
end;

procedure TclServerThread.Execute;
var
  dwResult: DWORD;
begin
  try
    FStopEvent := 0;
    FConnections := nil;
    FWindowHandle := 0;
    FServerSocket := INVALID_SOCKET;
    try
      OpenServerSocket();
      SetEvent(FStartedEvent);

      repeat
        dwResult := MsgWaitForMultipleObjects(1, FStopEvent, FALSE, INFINITE, QS_ALLEVENTS or QS_ALLINPUT);
        case dwResult of
          WAIT_OBJECT_0 + 1: DispatchMessages();
        end;
      until dwResult = WAIT_OBJECT_0;

    finally
      CloseServerSocket();
    end;
  except
    on E: Exception do
    begin
      Assert(FServer <> nil);
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'Execute ServerError', E);{$ENDIF}
      FServer.ServerError(E);
    end;
  end;
  if (FStartedEvent <> 0) then
  begin
    SetEvent(FStartedEvent);
  end;
end;

procedure TclServerThread.CloseConnection(AConnection: TclCommandConnection);
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'CloseConnection');{$ENDIF}
  if (AConnection = nil) or (FConnections.IndexOf(AConnection) < 0) then Exit;
  AConnection.BeginWork();
  try
    FConnections.Remove(AConnection);
  finally
    AConnection.EndWork();
  end;
  AConnection.Abort();
  FServer.CloseConnection(AConnection);
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'CloseConnection'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'CloseConnection', E); raise; end; end;{$ENDIF}
end;

procedure TclServerThread.ReadConnection(AConnection: TclCommandConnection);
begin
  Assert(FServer <> nil);
  FServer.ReadConnection(AConnection);
end;

procedure TclServerThread.AcceptConnection;
var
  connection: TclCommandConnection;
  res: Integer;
begin
  Assert(FServer <> nil);
  connection := FServer.CreateConnection();
  try
    FConnections.Add(connection);
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'AcceptConnection');{$ENDIF}
    connection._AddRef();

    if (FServer.UseTLS = stImplicit) then
    begin
      connection.NetworkStream := TclTlsNetworkStream.Create();
      TclTlsNetworkStream(connection.NetworkStream).OnGetCertificate := FServer.GetCertificate;
      TclTlsNetworkStream(connection.NetworkStream).TLSFlags := FServer.TLSFlags;
      TclTlsNetworkStream(connection.NetworkStream).RequireClientCertificate := FServer.RequireClientCertificate;
      TclTlsNetworkStream(connection.NetworkStream).OnVerifyPeer := FServer.VerifyClient;
    end else
    begin
      connection.NetworkStream := TclNetworkStream.Create();
    end;

    connection.Socket := FServerSocket;
    connection.BatchSize := FServer.BatchSize;
    connection.BitsPerSec := FServer.BitsPerSec;
    connection.OnReady := AcceptConnectionDone;

    connection.AcceptConnection();
    
    res := WSAAsyncSelect(connection.Socket, FWindowHandle, CL_SOCKETEVENT, FD_READ + FD_WRITE + FD_CLOSE);
    if (res = SOCKET_ERROR) then
    begin
      RaiseSocketError(WSAGetLastError());
    end;

    connection.AcceptConnectionDone();
  except
    FServer.CloseConnection(connection);
    raise;
  end;
end;

procedure TclServerThread.AcceptConnectionDone(Sender: TObject);
begin
  FServer.DoAcceptConnection(Sender as TclCommandConnection);
  (Sender as TclCommandConnection).OnReady := nil;
end;

procedure TclServerThread.CloseServerSocket;
begin
  if (FServerSocket <> INVALID_SOCKET) then
  begin
    shutdown(FServerSocket, SD_BOTH);
    closesocket(FServerSocket);
  end;
  if (FWindowHandle <> 0) then
  begin
    DeallocateHWnd(FWindowHandle);
  end;
  ClearConnections();
  FConnections.Free();
  if (FStopEvent > 0) then
  begin
    CloseHandle(FStopEvent);
    FStopEvent := 0;
  end;
end;

procedure TclServerThread.OpenServerSocket;
var
  srv_address: TSockAddrIn;
  res: Integer;
begin
  FStopEvent := CreateEvent(nil, False, False, nil);
  if (FStopEvent = 0) then
  begin
    RaiseSocketError(GetLastError());
  end;

  FConnections := TList.Create();
  FWindowHandle := AllocateHWnd(WndProc);
  if (FWindowHandle = 0) then
  begin
    RaiseSocketError(GetLastError());
  end;

  FServerSocket := socket(AF_INET, SOCK_STREAM, 0);
  if (FServerSocket = INVALID_SOCKET) then
  begin
    RaiseSocketError(WSAGetLastError());
  end;

  srv_address.sin_family := AF_INET;
  srv_address.sin_addr.s_addr := INADDR_ANY;

  if (FServer.Port <= 0) then
  begin
    raise EclSocketError.Create(cInvalidPort, -1);
  end;
  srv_address.sin_port := htons(FServer.Port);

  res := bind(FServerSocket, TSockAddr(srv_address), SizeOf(TSockAddrIn));
  if (res = SOCKET_ERROR) then
  begin
    RaiseSocketError(WSAGetLastError());
  end;

  res := WSAAsyncSelect(FServerSocket, FWindowHandle, CL_SOCKETEVENT, FD_ACCEPT);
  if (res = SOCKET_ERROR) then
  begin
    RaiseSocketError(WSAGetLastError());
  end;

  res := listen(FServerSocket, SOMAXCONN);
  if (res = SOCKET_ERROR) then
  begin
    RaiseSocketError(WSAGetLastError());
  end;
end;

function TclServerThread.FindConnection(ASocket: TSocket): TclCommandConnection;
var
  i: Integer;
begin
  for i := 0 to FConnections.Count - 1 do
  begin
    Result := TclCommandConnection(FConnections[i]);
    if (Result.Socket = ASocket) then Exit;
  end;
  Result := nil;
end;

procedure TclServerThread.ClearConnections;
begin
  while FConnections.Count > 0 do
  begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'ClearConnections, %d', nil, [FConnections.Count]);{$ENDIF}
    TclCommandConnection(FConnections[FConnections.Count - 1])._Release();
    FConnections.Delete(FConnections.Count - 1);
  end;
end;