CentrED/Client/UdmNetwork.pas

370 lines
11 KiB
Plaintext

(*
* 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;
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;
FUsername: string;
FPassword: string;
FAccessLevel: TAccessLevel;
FDataDir: string;
FLastPacket: TDateTime;
procedure OnCanSend(ASocket: TLSocket);
procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure ProcessQueue;
procedure DoLogin;
public
property Username: string read FUsername;
property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel;
procedure Send(APacket: TPacket);
procedure Disconnect;
procedure CheckClose(ASender: TForm);
end;
var
dmNetwork: TdmNetwork;
implementation
uses
UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize,
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmVirtualLayer, UfrmFilter, UfrmRegionControl;
{$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);
begin
MessageDlg('Connection error', msg, 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;
serverState: TServerState;
begin
subID := ABuffer.ReadByte;
case subID of
$01:
begin
if ABuffer.ReadCardinal = ProtocolVersion then
begin
frmInitialize.lblStatus.Caption := 'Authenticating';
Send(TLoginRequestPacket.Create(FUsername, FPassword));
end else
begin
MessageDlg('Error', 'Invalid protocol version. Maybe your client is outdated.', mtError, [mbOK], 0);
Disconnect;
end;
end;
$03:
begin
loginState := TLoginState(ABuffer.ReadByte);
if loginState = lsOK then
begin
frmInitialize.lblStatus.Caption := 'Initializing';
frmInitialize.Repaint;
frmInitialize.lblStatus.Repaint;
Application.ProcessMessages;
FAccessLevel := TAccessLevel(ABuffer.ReadByte);
InitGameResourceManager(FDataDir);
width := ABuffer.ReadWord;
height := ABuffer.ReadWord;
ResMan.InitLandscape(width, height);
ResMan.Landscape.UpdateWriteMap(ABuffer);
frmMain := TfrmMain.Create(dmNetwork);
frmRadarMap := TfrmRadarMap.Create(frmMain);
frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain);
frmRegionControl := TfrmRegionControl.Create(frmMain);
frmAccountControl := TfrmAccountControl.Create(frmMain);
frmEditAccount := TfrmEditAccount.Create(frmAccountControl);
frmConfirmation := TfrmConfirmation.Create(frmMain);
frmDrawSettings := TfrmDrawSettings.Create(frmMain);
frmMoveSettings := TfrmMoveSettings.Create(frmMain);
frmElevateSettings := TfrmElevateSettings.Create(frmMain);
frmHueSettings := TfrmHueSettings.Create(frmMain);
frmBoundaries := TfrmBoundaries.Create(frmMain);
frmFilter := TfrmFilter.Create(frmMain);
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain);
frmAbout := TfrmAbout.Create(frmMain);
frmMain.Show;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
if loginState = lsInvalidUser then
MessageDlg('Error', 'The username you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsInvalidPassword then
MessageDlg('Error', 'The password you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsAlreadyLoggedIn then
MessageDlg('Error', 'There is already a client logged in using that account.', mtWarning, [mbOK], 0)
else if loginState = lsNoAccess then
MessageDlg('Error', 'This account has no access.', mtWarning, [mbOK], 0);
end;
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 := 'The server is currently paused.';
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(frmDrawSettings);
FreeAndNil(frmMoveSettings);
FreeAndNil(frmElevateSettings);
FreeAndNil(frmHueSettings);
FreeAndNil(frmBoundaries);
FreeAndNil(frmFilter);
FreeAndNil(frmVirtualLayer);
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
if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then
begin
FUsername := frmLogin.edUsername.Text;
FPassword := frmLogin.edPassword.Text;
FDataDir := frmLogin.edData.Text;
frmInitialize.lblStatus.Caption := 'Connecting';
frmInitialize.Show;
Break;
end else
MessageDlg('Error', 'Cannot connect to the specified server.', 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.