CentrED/Client/UdmNetwork.pas

429 lines
16 KiB
Plaintext
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UdmNetwork;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Dialogs, lNetComponents, lNet,
UEnhancedMemoryStream, UPacket, UEnums, ExtCtrls, dateutils, LConvEncoding;
type
{ TdmNetwork }
TdmNetwork = class(TDataModule)
TCPClient: TLTCPComponent;
tmNoOp: TTimer;
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
procedure TCPClientConnect(aSocket: TLSocket);
procedure TCPClientDisconnect(aSocket: TLSocket);
procedure TCPClientError(const msg: string; aSocket: TLSocket);
procedure TCPClientReceive(aSocket: TLSocket);
procedure tmNoOpStartTimer(Sender: TObject);
procedure tmNoOpTimer(Sender: TObject);
protected
FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream;
FProfile: string;
FUsername: string;
FPassword: string;
FAccessLevel: TAccessLevel;
FServerStart: TDateTime;
FDataDir: string;
FLastPacket: TDateTime;
procedure OnCanSend(ASocket: TLSocket);
procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure ProcessQueue;
procedure DoLogin;
public
property Profile: string read FProfile;
property Username: string read FUsername;
property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel;
property ServerStart: TDateTime read FServerStart;
procedure Send(APacket: TPacket);
procedure Disconnect;
procedure CheckClose(ASender: TForm);
public
ErrorCaption: string;
WrongServer: string;
WrongAccount: string;
WrongPassword: string;
NoAccess: string;
AlreadyLogined: string;
TCPErrorCaption: string;
UnsuportedVersion: string;
end;
var
dmNetwork: TdmNetwork;
implementation
uses
UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize,
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand, UfrmFillSettings,
UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, UfrmLightlevel, UfrmSelectionSettings,
UfrmSurfElevateSettings, UfrmSurfStretchSettings, UfrmSurfSmoothSettings,
Logging, Language;
{$I version.inc}
{ TdmNetwork }
procedure TdmNetwork.DataModuleCreate(Sender: TObject);
begin
FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create;
TCPClient.OnCanSend := @OnCanSend;
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlingPacket);
DoLogin;
end;
procedure TdmNetwork.DataModuleDestroy(Sender: TObject);
begin
FreeAndNil(FSendQueue);
FreeAndNil(FReceiveQueue);
FreeAndNil(PacketHandlers[$02]);
end;
procedure TdmNetwork.TCPClientConnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
end;
procedure TdmNetwork.TCPClientDisconnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
DoLogin;
end;
procedure TdmNetwork.TCPClientError(const msg: string; aSocket: TLSocket);
var
rumsg : string;
begin
rumsg := CP1251ToUTF8(msg);
MessageDlg(TCPErrorCaption, rumsg, mtError, [mbOK], 0);
if not TCPClient.Connected then
TCPClientDisconnect(aSocket);
end;
procedure TdmNetwork.TCPClientReceive(aSocket: TLSocket);
var
buffer: array[0..4095] of byte;
size: Integer;
begin
repeat
size := TCPClient.Get(buffer, 4096);
if size > 0 then
FReceiveQueue.Enqueue(buffer, size);
until size <= 0;
ProcessQueue;
end;
procedure TdmNetwork.tmNoOpStartTimer(Sender: TObject);
begin
FLastPacket := Now;
end;
procedure TdmNetwork.tmNoOpTimer(Sender: TObject);
begin
if SecondsBetween(FLastPacket, Now) > 25 then
Send(TNoOpPacket.Create);
end;
procedure TdmNetwork.OnCanSend(ASocket: TLSocket);
var
size: Integer;
begin
while FSendQueue.Size > 0 do
begin
FLastPacket := Now;
size := TCPClient.Send(FSendQueue.Memory^, FSendQueue.Size);
if size > 0 then
FSendQueue.Dequeue(size)
else
Break;
end;
end;
procedure TdmNetwork.OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
var
subID: Byte;
loginState: TLoginState;
width, height: Word;
flags: Cardinal;
serverState: TServerState;
date, time: TDateTime;
begin
subID := ABuffer.ReadByte;
case subID of
$01:
begin
if (ABuffer.ReadCardinal - $1000) = ProtocolVersion then
begin
frmInitialize.lblStatus.Caption := frmInitialize.SplashAuthorization;
Send(TLoginRequestPacket.Create(FUsername, FPassword));
end else
begin // sLineBreak
MessageDlg(ErrorCaption, UnsuportedVersion, mtError, [mbOK], 0);
Disconnect;
end;
Logger.Send([lcClient, lcInfo], 'Текущая версия протокола подтверждена');
end;
$03:
begin
loginState := TLoginState(ABuffer.ReadByte);
if loginState = lsOK then
begin
frmInitialize.SetStatusLabel(frmInitialize.SplashInicialization);
Application.ProcessMessages;
FAccessLevel := TAccessLevel(ABuffer.ReadByte);
FServerStart := IncSecond(Now, - ABuffer.ReadDWord);
width := ABuffer.ReadWord;
height := ABuffer.ReadWord;
flags := ABuffer.ReadCardinal;
// Для совместимости с сервером 0.7.0 (ранее тут слалось число преметов)
if (flags and $FF000000) = 0 then // GameResourceManager.Tiledata.StaticCount
if flags < $C000 then flags := $F0000000 else flags := $F0000008;
if not InitGameResourceManager(FDataDir, Flags) then begin
Logger.Send([lcClient, lcInfo], 'CentrED+ загрузка отменена, не та версия *.mul файлов.');
Disconnect; exit;
end;
ResMan.InitLandscape(width, height);
// Проверка обновлений
frmInitialize.SetStatusLabel(frmInitialize.SplashUpdates);
Logger.Send([lcClient, lcInfo], 'Начало загрузки CentrED+');
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['OpenGL Device']));
ResMan.Landscape.UpdateWriteMap(ABuffer); Logger.Send([lcClient, lcInfo], 'ResMan.Landscape.UpdateWriteMap(ABuffer);');
frmMain := TfrmMain.Create(dmNetwork); Logger.Send([lcClient, lcInfo], 'frmMain := TfrmMain.Create(dmNetwork);');
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['Windows Forms']));
frmRadarMap := TfrmRadarMap.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmRadarMap := TfrmRadarMap.Create(frmMain);');
frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain);');
frmRegionControl := TfrmRegionControl.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmRegionControl := TfrmRegionControl.Create(frmMain);');
frmAccountControl := TfrmAccountControl.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmAccountControl := TfrmAccountControl.Create(frmMain);');
frmEditAccount := TfrmEditAccount.Create(frmAccountControl); Logger.Send([lcClient, lcInfo], 'frmEditAccount := TfrmEditAccount.Create(frmAccountControl);');
frmConfirmation := TfrmConfirmation.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmConfirmation := TfrmConfirmation.Create(frmMain);');
frmSelectionSettings := TfrmSelectionSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmSelectionSettings := TfrmSelectionSettings.Create(frmMain);');
frmMoveSettings := TfrmMoveSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmMoveSettings := TfrmMoveSettings.Create(frmMain);');
frmElevateSettings := TfrmElevateSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmElevateSettings := TfrmElevateSettings.Create(frmMain);');
frmSurfElevateSettings := TfrmSurfElevateSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmSurfElevateSettings := TfrmSurfElevateSettings.Create(frmMain);');
frmSurfStretchSettings := TfrmSurfStretchSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmSurfStretchSettings := TfrmSurfStretchSettings.Create(frmMain);');
frmSurfSmoothSettings := TfrmSurfSmoothSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmSurfSmoothSettings := TfrmSurfSmoothSettings.Create(frmMain);');
frmDrawSettings := TfrmDrawSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmDrawSettings := TfrmDrawSettings.Create(frmMain);');
frmHueSettings := TfrmHueSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmHueSettings := TfrmHueSettings.Create(frmMain);');
frmFillSettings := TfrmFillSettings.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmFillSettings := TfrmFillSettings.Create(frmMain);');
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmVirtualLayer := TfrmVirtualLayer.Create(frmMain)');
frmBoundaries := TfrmBoundaries.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmBoundaries := TfrmBoundaries.Create(frmMain);');
frmFilter := TfrmFilter.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmFilter := TfrmFilter.Create(frmMain);');
frmLightlevel := TfrmLightlevel.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmLightlevel := TfrmLightlevel.Create(frmMain);');
frmAbout := TfrmAbout.Create(frmMain); Logger.Send([lcClient, lcInfo], 'frmAbout := TfrmAbout.Create(frmMain);');
frmMain.mnuTileListViewClick(nil);
frmMain.Show; Logger.Send([lcClient, lcInfo], 'frmMain.Show;');
frmInitialize.Hide; Logger.Send([lcClient, lcInfo], 'frmInitialize.Hide;');
tmNoOp.Enabled := True; Logger.Send([lcClient, lcInfo], 'tmNoOp.Enabled := True;');
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['Done']));
end else
begin
if loginState = lsInvalidUser then
MessageDlg(ErrorCaption, WrongAccount, mtWarning, [mbOK], 0)
else if loginState = lsInvalidPassword then
MessageDlg(ErrorCaption, WrongPassword, mtWarning, [mbOK], 0)
else if loginState = lsAlreadyLoggedIn then
MessageDlg(ErrorCaption, AlreadyLogined, mtWarning, [mbOK], 0)
else if loginState = lsNoAccess then
MessageDlg(ErrorCaption, NoAccess, mtWarning, [mbOK], 0);
end;
Logger.Send([lcClient, lcInfo], 'CentrED+ запущен.');
end;
$04: //Server state
begin
serverState := TServerState(ABuffer.ReadByte);
if serverState = ssRunning then
begin
frmInitialize.UnsetModal;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
case serverState of
ssFrozen: frmInitialize.lblStatus.Caption := frmInitialize.SplashSuspend;
ssOther: frmInitialize.lblStatus.Caption := ABuffer.ReadStringNull
end;
tmNoOp.Enabled := False;
frmInitialize.Show;
frmInitialize.SetModal;
end;
end;
end;
end;
procedure TdmNetwork.ProcessQueue;
var
packetHandler: TPacketHandler;
size: Cardinal;
begin
FReceiveQueue.Position := 0;
while FReceiveQueue.Size >= 1 do
begin
packetHandler := PacketHandlers[FReceiveQueue.ReadByte];
if packetHandler <> nil then
begin
size := packetHandler.PacketLength;
if size = 0 then
begin
if FReceiveQueue.Size > 5 then
size := FReceiveQueue.ReadCardinal
else
Break; //wait for more data
end;
if FReceiveQueue.Size >= size then
begin
FReceiveQueue.Lock(FReceiveQueue.Position, size - FReceiveQueue.Position); //prevent handler from reading too much
packetHandler.Process(FReceiveQueue);
FReceiveQueue.Unlock;
FReceiveQueue.Dequeue(size);
end else
Break; //wait for more data
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);}
Disconnect;
FReceiveQueue.Clear;
end;
end;
end;
procedure TdmNetwork.DoLogin;
begin
tmNoOp.Enabled := False;
frmLogin := TfrmLogin.Create(dmNetwork);
if frmInitialize = nil then
frmInitialize := TfrmInitialize.Create(dmNetwork);
FreeAndNil(frmEditAccount);
FreeAndNil(frmAccountControl);
FreeAndNil(frmConfirmation);
FreeAndNil(frmSelectionSettings);
FreeAndNil(frmMoveSettings);
FreeAndNil(frmElevateSettings);
FreeAndNil(frmSurfElevateSettings);
FreeAndNil(frmSurfStretchSettings);
FreeAndNil(frmSurfSmoothSettings);
FreeAndNil(frmDrawSettings);
FreeAndNil(frmHueSettings);
FreeAndNil(frmFillSettings);
FreeAndNil(frmVirtualLayer);
FreeAndNil(frmBoundaries);
FreeAndNil(frmFilter);
FreeAndNil(frmLightlevel);
FreeAndNil(frmAbout);
FreeAndNil(frmRegionControl);
FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRadarMap);
if frmMain <> nil then
begin
frmMain.ApplicationProperties1.OnIdle := nil;
FreeAndNil(frmMain);
end;
FreeAndNil(GameResourceManager);
frmInitialize.Hide;
while frmLogin.ShowModal = mrOK do
begin
LanguageTranslate(frmInitialize, self, nil);
if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then
begin
if frmLogin.cbProfile.ItemIndex > -1
then FProfile := frmLogin.cbProfile.Text
else FProfile := '---';
FUsername := frmLogin.edUsername.Text;
FPassword := frmLogin.edPassword.Text;
FDataDir := UTF8ToCP1251(frmLogin.edData.Text);
frmInitialize.lblStatus.Caption := frmInitialize.SplashConnection;
frmInitialize.Show;
Break;
end else
MessageDlg(ErrorCaption, WrongServer, mtError, [mbOK], 0);
end;
frmLogin.Close;
FreeAndNil(frmLogin);
end;
procedure TdmNetwork.Send(APacket: TPacket);
var
source: TEnhancedMemoryStream;
begin
if TCPClient.Connected then
begin
FSendQueue.Seek(0, soFromEnd);
source := APacket.Stream;
FSendQueue.CopyFrom(source, 0);
OnCanSend(nil);
end;
APacket.Free;
end;
procedure TdmNetwork.Disconnect;
begin
Send(TQuitPacket.Create);
end;
procedure TdmNetwork.CheckClose(ASender: TForm);
begin
if ((frmLogin = nil) or (ASender = frmLogin)) and
((frmMain = nil) or (ASender = frmMain)) and
((frmInitialize = nil) or (not frmInitialize.Visible)) then
begin
Application.Terminate;
end;
end;
initialization
{$I UdmNetwork.lrs}
end.