Shockwave Multiuser Server Implementation

smus.pas

{
SMUS (Shockwave Multi User Server) types
SSG - 02 Dec 2001
}

unit smus;

interface

uses

  Blowfish, WinSock, Classes, SysUtils, Windows;

type

  {
    proplist format:

    numitems DWORD
        type    word
        value   variant
        .
        .
        numitems
  }

  TSMUSPoint = packed record
    X : integer;
    Y : integer;
  end;

  TSMUSRect = packed record
    Top : integer;
    Left : integer;
    Bottom : integer;
    Right : integer;
  end;

  TSMUSColor = packed record
    Data : array[0..3] of byte;
  end;

  TSMUSDate = packed record
    Data : array[0..15] of byte;
  end;

  TSMUSString = packed record
    length : dword;
    data   : record end;
  end;

  TSMUS3dVector = packed record
    X,Y,Z : double;
  end;

  TSMUS3dTransform = packed record
    x1,y1,z1,a1 : double;
    x2,y2,z2,a2 : double;
    x3,y3,z3,a3 : double;
    x4,y4,z4,a4 : double;
  end;

  PSMUSPacket = ^TSMUSPacket;
  TSMUSPacket = packed record
    HeaderTag : word;
    MessageSize : integer;
    ErrorCode : integer;
    TimeStamp : integer;
    VariableData : record end;
  end;

  TSMUSMessage = class(TObject)
  private
    FErrorCode : integer;
    FTimeStamp : integer;
    FSubject : string;
    FSenderID : string;
    FRecipients : TStringList;
    FContentType : integer;
    FContents : string;

    procedure ParsePacket(packet:PSMUSPacket; size:integer);
  public
    constructor Create(var buffer);overload;
    constructor Create(ErrorCode:integer; Subject,SenderId:string;
      Recipients:array of string);overload;
    destructor Destroy;override;

    function BuildPacket:PSMUSPacket;
    function getPacketSize:integer;

    procedure setContentStringList(strings:array of string);

    property Size:integer read getPacketSize;
    property ErrorCode:integer read FErrorCode write FErrorCode;
    property TimeStamp:integer read FTimeStamp write FTimeStamp;
    property Recipients:TStringList read FRecipients;
    property Subject:string read FSubject write FSubject;
    property SenderID:string read FSenderID write FSenderID;
    property ContentType:integer read FContentType write FContentType;
    property Contents:string read FContents write FContents;
  end;

const

  SMUSPacketHeader = byte('r');
  SMUSMinPacketSize = 34;

  SMUSKey = 'IPAddress resolution';

  // lingo value types (word)

  mmVoid = 0; // nothing
  mmInteger = 1; // integer
  mmSymbol = 2; // smusstring
  mmString = 3; // smusstring
  mmPicture = 5; // smusstring
  mmFloat = 6; // double (non-intel)
  mmList = 7; // list of values
  mmPoint = 8; // smuspoint
  mmRect = 9; // smusrect
  mmPropList = 10; // list of values
  mmColor = 18; // smuscolor
  mmDate = 19; // smusdate
  mmMedia = 20; // smusstring
  mm3dVector = 22; // smus3dvector
  mm3dTransform = 23; // smus3dtransform

implementation

procedure BlowFishDecrypt(var inbuf,outbuf; bufsize:integer; const key:string);
var
  Data:TBlowFishData;
begin
  FillChar(Data,SizeOf(Data),0);
  BlowfishInit(Data,@key[1],length(Key),NIL);
  BlowfishDecryptCFB(Data,@inbuf,@outbuf,bufsize);
  BlowfishBurn(Data);
end;

// utility function to calculate smus packet string lengths

function SMUSLength(const s:string):integer;
begin
  Result := length(s);
  if (Result > 0) and ((Result mod 2) = 1) then inc(Result);
end;

procedure putString(var P:PLongint; s:string);
begin
  P^ := htonl(length(s));
  inc(integer(P),SizeOf(integer));
  Move(s[1],P^,length(s));
  inc(integer(P),SMUSLength(s));
end;

{ TSMUSMessage }

constructor TSMUSMessage.Create(var buffer);
var
  P:PSMUSPacket;
  size:integer;
begin
  inherited Create;
  P := @buffer;
  if P^.HeaderTag <> SMUSPacketHeader then
    raise Exception.Create('Invalid SMUS Packet Header!?');
  size := ntohl(P^.MessageSize);
  FRecipients := TStringList.Create;
  ParsePacket(@buffer,size);
end;

procedure TSMUSMessage.ParsePacket;
var
  P:PLongint;
  n,itemCount,i,index,bufsize:integer;
  s:string;
  TempBuf:pointer;

  procedure checkIndex;
  begin
    if index >= ntohl(packet^.MessageSize) then
      raise Exception.Create('packet index overflow (possible invalid packet)');
  end;

  function parseString(var P:PLongint):string;
  var
    l:integer;
  begin
    l := ntohl(P^);
    Result := '';
    checkIndex;
    if l > 0 then begin
      SetLength(Result,l);
      Move(pointer(integer(P)+4)^,Result[1],l);
      if l mod 2 > 0 then inc(l);
      inc(integer(P),l+4);
      inc(index,l+4);
      Result := Result;
    end else begin
      inc(integer(P),4);
      inc(index,4);
    end;
  end;
  
  procedure ParseContents(P:Pointer; bufsize:integer);
  var
    w:word;
  begin
    w := ntohs(PWord(P)^);
    FContentType := w;
    inc(integer(P),2);
    case FContentType of
      mmString : begin
        FContents := parseString(PLongint(P));
        if FSubject = 'Logon' then begin
          SetLength(s,length(FContents));
          BlowfishDecrypt(FContents[1],s[1],length(s),SMUSKey);
          FContents := s;
        end;
      end;
      mmVoid : FContents := '';
      else begin
        SetLength(FContents,bufsize-2);
        Move(P^,FContents[1],bufsize-2);
      end;
    end; {case}
  end;

begin
  if (packet <> NIL) then begin
    with packet^ do begin
      FErrorCode := ntohl(ErrorCode);
      FTimeStamp := ntohl(TimeStamp);
      P := @VariableData;
      index := integer(P)-integer(packet);
      FSubject := parseString(P);
      FSenderID := parseString(P);
      if FRecipients.Count > 0 then FRecipients.Clear;
      checkIndex;
      itemCount := ntohl(P^);
      inc(integer(P),4);
      inc(index,4);
      for n := 1 to itemCount do begin
        checkIndex;
        i := ntohl(P^);
        SetLength(s,i);
        inc(integer(P),4);
        Move(P^,s[1],i);
        FRecipients.Add(s);
        // if (i mod 2 > 0) then inc(i);
        inc(integer(P),i);
        inc(index,i+4);
      end;
      if index mod 2 > 0 then begin
        inc(integer(P));
        inc(index);
      end;
      bufsize := ntohl(packet^.MessageSize)-(integer(P)-integer(@packet^.ErrorCode))-2;
      if FSubject = 'Logon' then begin
        GetMem(TempBuf,bufsize);
        BlowfishDecrypt(P^,TempBuf^,bufsize,SMUSKey);

        ParseContents(TempBuf,bufsize);
        FreeMem(TempBuf,bufsize);
      end else ParseContents(P,bufsize);
    end;
  end;
end;

constructor TSMUSMessage.Create(ErrorCode:integer; Subject, SenderId: string;
  Recipients: array of string);
var
  n:integer;
begin
  inherited Create;
  FErrorCode := ErrorCode;
  FTimeStamp := GetTickCount;
  FSubject := Subject;
  FSenderId := SenderId;
  FRecipients := TStringList.Create;
  for n:=0 to High(Recipients) do
    FRecipients.Add(Recipients[n]);
  FContentType := ContentType;
  FContents := Contents;
end;

destructor TSMUSMessage.Destroy;
begin
  if FRecipients <> NIL then FRecipients.Free;
  inherited;
end;

function TSMUSMessage.BuildPacket: PSMUSPacket;
var
  Packet:PSMUSPacket;
  P:PLongint;
  size,n:integer;
begin
  size := getPacketSize;
  GetMem(Packet,size);
  FillChar(Packet^,size,0);
  with Packet^ do begin
    HeaderTag := SMUSPacketHeader;
    MessageSize := htonl(size-(SizeOf(HeaderTag)+SizeOf(MessageSize)));
    ErrorCode := htonl(FErrorCode);
    TimeStamp := htonl(FTimeStamp);
    P := @VariableData;
    putString(P,FSubject);
    putString(P,FSenderID);
    P^ := htonl(FRecipients.Count);
    inc(integer(P),4);
    for n:=0 to FRecipients.Count-1 do
      putString(P,FRecipients[n]);
    PWord(P)^ := htons(FContentType);
    inc(integer(P),2);
    case FContentType of
      mmString : putString(P,FContents);
      else Move(FContents[1],P^,length(FContents));
    end; {Case}
  end;
  Result := Packet;
end;

function TSMUSMessage.getPacketSize;
var
  n:integer;
begin
  Result := SizeOf(integer);
  for n:=0 to FRecipients.Count-1 do
    inc(Result,SizeOf(integer)+SMUSLength(FRecipients[n])); // recipients
  case FContentType of
    mmString :
      inc(Result,SizeOf(integer)+SMUSLength(FContents));
    mmVoid : ;
    else
      inc(Result,length(FContents));
  end; {content length}
  inc(Result,SizeOf(TSMUSPacket)+ // stub
            SizeOf(integer)+SMUSLength(FSubject) + // subject
            SizeOf(integer)+SMUSLength(FSenderID) + // senderid
            SizeOf(word)); // content type
end;

procedure TSMUSMessage.setContentStringList(strings: array of string);
var
  n,len:integer;
  P:PLongint;
begin
  FContentType := mmList;
  len := SizeOf(integer);
  for n:=0 to High(strings) do inc(len,SMUSLength(strings[n])+SizeOf(integer)+SizeOf(word));
  SetLength(FContents,len);
  FillChar(FContents[1],len,0);
  P := @(FContents[1]);
  P^ := htonl(High(strings)+1);
  inc(integer(P),SizeOf(integer));
  for n:=0 to High(strings) do begin
    PWord(P)^ := htons(mmString);
    inc(integer(P),sizeOf(word));
    putString(P,strings[n]);
  end;
end;

end.