cltcpserver.pas

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

procedure TclServerThread.WndProc(var Message: TMessage);
begin
  if (Message.Msg <> CL_SOCKETEVENT) then Exit;
  case LOWORD(Message.lParam) of
    FD_ACCEPT: AcceptConnection();
    FD_READ: ReadConnection(FindConnection(TSocket(Message.wParam)));
    FD_WRITE: WriteConnection(FindConnection(TSocket(Message.wParam)));
    FD_CLOSE: CloseConnection(FindConnection(TSocket(Message.wParam)));
  end;
end;

procedure TclServerThread.DispatchMessages;
var
  msg: TMsg;
begin
  while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
  begin
    DispatchMessage(msg);
  end;
end;

procedure TclServerThread.Stop;
begin
  SetEvent(FStopEvent);
  WaitForSingleObject(Handle, INFINITE);
end;

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

procedure TclServerThread.Start;
begin
  FStartedEvent := CreateEvent(nil, False, False, nil);
  if (FStartedEvent = 0) then
  begin
    RaiseSocketError(GetLastError());
  end;
  try
    Resume();
    WaitForSingleObject(FStartedEvent, INFINITE);
  finally
    CloseHandle(FStartedEvent);
    FStartedEvent := 0;
  end;
end;

{ TclTcpCommandServer }

procedure TclTcpCommandServer.AddCommand(AInfo: TclTcpCommandInfo);
begin
  FCommands.Add(AInfo);
end;

procedure TclTcpCommandServer.ClearCommands;
var
  i: Integer;
begin
  for i := 0 to FCommands.Count - 1 do
  begin
    TObject(FCommands[i]).Free();
  end;
  FCommands.Clear();
end;

constructor TclTcpCommandServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCommands := TList.Create();
  RegisterCommands();
end;

procedure TclTcpCommandServer.DoReadConnection(AConnection: TclCommandConnection; AData: TStream);
var
  command: string;
begin
  inherited DoReadConnection(AConnection, AData);

  AData.Position := 0;
  SetLength(command, AData.Size);
  AData.Read(PChar(command)^, AData.Size);

  ProcessData(AConnection, command);
end;

function TclTcpCommandServer.GetCommand(const AName: string): TclTcpCommandInfo;
var
  i: Integer;
begin
  for i := 0 to FCommands.Count - 1 do
  begin
    Result := TclTcpCommandInfo(FCommands[i]);
    if (Result.Name = AName) then Exit;
  end;
  Result := nil;
end;

function TclTcpCommandServer.GetCommandParams(const AData: string): TclTcpCommandParams;
var
  ind: Integer;
begin
  Result := TclTcpCommandParams.Create();

  ind := Pos(#32, AData);
  if (ind > 0) then
  begin
    Result.Command := UpperCase(system.Copy(AData, 1, ind - 1));
    Result.Params := system.Copy(AData, ind + 1, Length(AData));
  end else
  begin
    Result.Command := UpperCase(AData);
  end;
end;

procedure TclTcpCommandServer.ProcessData(AConnection: TclCommandConnection;
  const AData: string);
var
  i: Integer;
  data: string;
  cmdList: TStrings;
  info: TclTcpCommandInfo;
  params: TclTcpCommandParams;
begin
  cmdList := TStringList.Create();
  try
    if AddTextStr(cmdList, AConnection.FCommandRaw + AData) and (cmdList.Count > 0) then
    begin
      AConnection.FCommandRaw := cmdList[cmdList.Count - 1];
      cmdList.Delete(cmdList.Count - 1);
    end else
    begin
      AConnection.FCommandRaw := '';
    end;

    for i := 0 to cmdList.Count - 1 do
    begin
      data := Trim(cmdList[i]);
      if (data <> '') then
      begin
        params := GetCommandParams(data);
        try
          info := GetCommand(params.Command);

          if (info <> nil) then
          begin
            ProcessCommand(AConnection, info, params);
          end else
          begin
            info := GetNullCommand(params.Command);
            try
              ProcessCommand(AConnection, info, params);
            finally
              info.Free();
            end;
          end;
        finally
          params.Free();
        end;
      end;
    end;
  finally
    cmdList.Free();
  end;
end;

procedure TclTcpCommandServer.DoProcessCommand(AConnection: TclCommandConnection;
  AInfo: TclTcpCommandInfo; AParams: TclTcpCommandParams);
begin
  Assert(AInfo <> nil);
  Assert(AParams <> nil);
  DoReceiveCommand(AConnection, AParams.Command, AParams.Params);
  AInfo.Execute(AConnection, AParams);
end;

procedure TclTcpCommandServer.SendResponse(AConnection: TclCommandConnection;
  const ACommand, AResponse: string);
begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'SendResponse, command: %s ', nil, [ACommand]);{$ENDIF}
  AConnection.WriteString(AResponse + #13#10);
  DoSendResponse(AConnection, ACommand, AResponse);
end;

procedure TclTcpCommandServer.SendResponse(AConnection: TclCommandConnection;
  const ACommand, AResponse: string; const Args: array of const);
begin
  SendResponse(AConnection, ACommand, Format(AResponse, Args));
end;

procedure TclTcpCommandServer.DoReceiveCommand(AConnection: TclCommandConnection;
  const ACommand, AParams: string);
begin
  if Assigned(OnReceiveCommand) then
  begin
    OnReceiveCommand(Self, AConnection, ACommand, AParams);
  end;
end;

procedure TclTcpCommandServer.DoSendResponse(
  AConnection: TclCommandConnection; const ACommand, AResponse: string);
begin
  if Assigned(OnSendResponse) then
  begin
    OnSendResponse(Self, AConnection, ACommand, AResponse);
  end;
end;

procedure TclTcpCommandServer.DoDestroy;
begin
  ClearCommands();
  FCommands.Free();
  inherited DoDestroy();
end;

procedure TclTcpCommandServer.DoWriteConnection(AConnection: TclCommandConnection);

  procedure WriteLine(AStream: TStream; const ALine: string);
  begin
    AStream.Write(PChar(ALine)^, Length(ALine));
  end;

const
  cDot = '.';
  cCRLF = #13#10;

var
  line: string;
  stream: TStream;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'DoWriteConnection');{$ENDIF}
  if (AConnection.FLines = nil) then Exit;

{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'DoWriteConnection, FLines <> nil');{$ENDIF}

  stream := TMemoryStream.Create();
  try
    while (AConnection.FCurrentLine < AConnection.FLines.Count) do
    begin
      line := AConnection.FLines[AConnection.FCurrentLine];

      if ((stream.Size + 3 + Length(line)) <= BatchSize) then
      begin
        if (Length(line) > 0) then
        begin
          if AConnection.FUseDotTerminator and (line[1] = '.') then
          begin
            WriteLine(stream, cDot);
          end;
          WriteLine(stream, line);
        end;
        WriteLine(stream, cCRLF);
      end else
      if (stream.Size > 0) then
      begin
        stream.Position := 0;
        AConnection.WriteData(stream);
        stream.Size := 0;
        stream.Position := 0;
        Continue;
      end;

      Inc(AConnection.FCurrentLine);
    end;

    if (stream.Size > 0) then
    begin
      stream.Position := 0;
      AConnection.WriteData(stream);
      stream.Size := 0;
      stream.Position := 0;
    end;

    WriteLine(stream, AConnection.FLinesTrailer + cCRLF);

    AConnection.SetLines(nil);
    AConnection.FLinesTrailer := '';

    stream.Position := 0;
    AConnection.WriteData(stream);
  finally
    stream.Free();
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'DoWriteConnection'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'DoWriteConnection', E); raise; end; end;{$ENDIF}
end;

procedure TclTcpCommandServer.AddMultipleLines(AConnection: TclCommandConnection; ALines: TStrings);
begin
  AConnection.SetLines(ALines);
end;

procedure TclTcpCommandServer.SendMultipleLines(AConnection: TclCommandConnection;
  const ALinesTrailer: string; AUseDotTerminator: Boolean);
begin
  Assert(AConnection.FLines <> nil);
  AConnection.FLinesTrailer := ALinesTrailer;
  AConnection.FUseDotTerminator := AUseDotTerminator;
  DoWriteConnection(AConnection);
end;

function TclTcpCommandServer.CheckForEndOfData(const AData: string): Boolean;
var
  len: Integer;
begin
  len := Length(AData);
  Result := False;

  if (len > 4) then
  begin
    Result := (system.Copy(AData, len - 4, 5) = #13#10'.'#13#10); //TODO check
  end else
  if (len = 3) then
  begin
    Result := (AData = '.'#13#10);
  end;
end;

procedure TclTcpCommandServer.ProcessCommand(AConnection: TclCommandConnection;
  AInfo: TclTcpCommandInfo; AParams: TclTcpCommandParams);
begin
  try
    DoProcessCommand(AConnection, AInfo, AParams);
  except
    on E: EclTcpCommandError do
    begin
      SendResponse(AConnection, E.Command, E.Message);
    end;
    on EAbort do ;
    on E: Exception do
    begin
      ProcessUnhandledError(AConnection, AParams, E);
      raise;
    end;
  end;
end;

procedure TclTcpCommandServer.ProcessUnhandledError(AConnection: TclCommandConnection;
  AParams: TclTcpCommandParams; E: Exception);
begin
end;

{ TclCommandConnection }

procedure TclCommandConnection.BeginWork;
begin
  FAccessor.Enter();
end;

constructor TclCommandConnection.Create;
begin
  inherited Create();
  FAccessor := TCriticalSection.Create();
  FWriteStream := TMemoryStream.Create();
end;

procedure TclCommandConnection.DoDestroy;
begin
  FLines.Free();
  FLines := nil;
  FWriteStream.Free();
  FAccessor.Free();
  inherited DoDestroy();
end;

procedure TclCommandConnection.EndWork;
begin
  FAccessor.Leave();
end;

procedure TclCommandConnection.SetLines(const Value: TStrings);
begin
  FCurrentLine := 0;
  FLines.Free();
  FLines := Value;
end;

procedure TclCommandConnection.WriteString(const AString: string);
var
  stream: TStream;
begin
  stream := TStringStream.Create(AString);
  try
    WriteData(stream);
  finally
    stream.Free();
  end;
end;

procedure TclCommandConnection.WriteData(AData: TStream);
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'WriteData');{$ENDIF}
  inherited WriteData(AData);

  if (AData.Position < AData.Size - 1) then
  begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'WriteData, if (Size = 0), %d, %d', nil, [FWriteStream.Size, AData.Size]);{$ENDIF}
    if (FWriteStream.Size = 0) then
    begin
      FWriteStream.Size := 0;
      FWriteStream.Position := 0;
      FWriteStream.CopyFrom(AData, AData.Size - AData.Position);
      FWriteStream.Position := 0;
    end;
    raise EAbort.Create('Would Block');
  end;

  FWriteStream.Size := 0;
  FWriteStream.Position := 0;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'WriteData'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'WriteData', E); raise; end; end;{$ENDIF}
end;

function TclCommandConnection.GetIsTls: Boolean;
begin
  Result := (NetworkStream is TclTlsNetworkStream);
end;

{ EclTcpCommandError }

constructor EclTcpCommandError.Create(const ACommand, AErrorMsg: string; AErrorCode: Integer);
begin
  inherited Create(AErrorMsg, AErrorCode);
  FCommand := ACommand;
end;

end.