unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdThreadMgr, IdThreadMgrDefault, IdIOHandlerSocket, IdIOHandler,
  IdIOHandlerStream, IdBaseComponent, IdComponent, IdTCPServer,
  IdServerIOHandler, IdServerIOHandlerSocket, StdCtrls, Winsock, ExtCtrls;

type
  PIXEL_FORMAT = packed record
    BitsPerPixel: byte;
    depth: byte;
    BigEndianFlag: byte;
    TrueColourFlag: byte;
    RedMax: Word;
    GreenMax: Word;
    BlueMax: Word;
    RedShift: byte;
    GreenBlue: byte;
    BlueShift: byte;
    Padding: Array[0..2] of byte;
  end;
  
  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    IdIOHandlerStream1: TIdIOHandlerStream;
    IdIOHandlerSocket1: TIdIOHandlerSocket;
    IdThreadMgrDefault1: TIdThreadMgrDefault;
    IdServerIOHandlerSocket1: TIdServerIOHandlerSocket;
    Label1: TLabel;
    Label2: TLabel;
    ListBox1: TListBox;
    Label3: TLabel;
    Image1: TImage;
    procedure IdTCPServer1Connect(AThread: TIdPeerThread);
    procedure IdTCPServer1Execute(AThread: TIdPeerThread);
  private
    { Private declarations }
    ServerPixelFormat: PIXEL_FORMAT;
    ClientPixelFormat: PIXEL_FORMAT;
    procedure writeProtocolVersionMsg(AThread: TIdPeerThread);
    procedure readProtocolVersionMsg(AThread: TIdPeerThread);
    function authenticate(AThread: TIdPeerThread):Boolean;
    procedure readClientInit(AThread: TIdPeerThread);
    procedure initServer(AThread: TIdPeerThread);
    procedure writeServerInit(AThread: TIdPeerThread);

    procedure readSetPixelFormat(AThread: TIdPeerThread);
    procedure readFixColourMapEntries(AThread: TIdPeerThread);
    procedure readSetEncodings(AThread: TIdPeerThread);
    procedure readFrameBufferUpdateRequest(AThread: TIdPeerThread);
    procedure readKeyEvent(AThread: TIdPeerThread);
    procedure readPointerEvent(AThread: TIdPeerThread);
    procedure readClientCutText(AThread: TIdPeerThread);
    procedure doFrameBufferUpdate(AThread: TIdPeerThread);

    procedure processRequest(AThread: TIdPeerThread);

  public
    { Public declarations }
  end;

const
	// Messages from client to server
  SetPixelFormat = 0;
	FixColourMapEntries = 1;
	SetEncodings = 2;
	FrameBufferUpdateRequest = 3;
	KeyEvent = 4;
	PointerEvent = 5;
	ClientCutText = 6;
var
  Form1: TForm1;

  updateIsAvailable: Boolean = False;

	// Authentication
	ConnFailed: byte = 0;
	NoAuth: byte = 1;
	VncAuth: byte = 2;
	VncAuthOK: Cardinal = 0;
	VncAuthFailed: Cardinal = 1;

	// Messages from server to client
	FrameBufferUpdate: byte = 0;
	SetColourMapEntries: byte = 1;
	Bell: byte = 2;
	ServerCutText: byte = 3;

  protocolVersion: String = 'RFB 003.008'+#10;
  
implementation

{$R *.dfm}

function Swap16(ASmallInt: Word): Word  ;
asm
  xchg al,ah
end;

function Swap32(value: Integer{dword}): Integer{dword} ; assembler ;
asm
  bswap eax
end;


procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
  // 
end;

procedure TForm1.writeProtocolVersionMsg(AThread: TIdPeerThread);
begin
  AThread.Connection.Write(protocolVersion);
end;

procedure TForm1.readProtocolVersionMsg(AThread: TIdPeerThread);
var
  protocolVersionMsg: String;
begin
  protocolVersionMsg := AThread.Connection.ReadLn;
  Label2.Caption := protocolVersionMsg;
end;

procedure TForm1.readClientInit(AThread: TIdPeerThread);
var
isShared: Byte;
begin
  AThread.Connection.ReadBuffer(isShared,1);
end;

procedure TForm1.initServer(AThread: TIdPeerThread);
begin
        // We may already have a shared server
end;

procedure TForm1.readSetPixelFormat(AThread: TIdPeerThread);
var
  padding: byte;
begin
  AThread.Connection.ReadBuffer(padding,3);
  AThread.Connection.ReadBuffer(ClientPixelFormat,16);
end;

procedure TForm1.readFixColourMapEntries(AThread: TIdPeerThread);

begin
end;

procedure TForm1.readSetEncodings(AThread: TIdPeerThread);
var
  padding: byte;
  i, numEncodings: Word;
  encType: Longint;
begin
  AThread.Connection.ReadBuffer(padding,1);
  AThread.Connection.ReadBuffer( {U16} numEncodings,2);
  numEncodings := Swap(numEncodings);
  Listbox1.Items.Add('Sum of Encodings: '+IntToStr(numEncodings));
  for i := 1 to numEncodings do begin
    AThread.Connection.ReadBuffer(encType,4);
    //encType := ntohl(encType);
    encType := Swap32(encType);
    Listbox1.Items.Add('Read Encoding: '+IntToStr(encType));
  end;

//{ numEncodings *  AThread.Connection.ReadBuffer( S32 encType,4); }
end;

procedure TForm1.readFrameBufferUpdateRequest(AThread: TIdPeerThread);
var
  incremental: byte;
  xpos, ypos, width, height: Word;
begin
  AThread.Connection.ReadBuffer( {U8} incremental,1);
  AThread.Connection.ReadBuffer( {U16} xpos,2);
  AThread.Connection.ReadBuffer( {U16} ypos,2);
  AThread.Connection.ReadBuffer( {U16} width,2);
  AThread.Connection.ReadBuffer( {U16} height,2);
  xpos := Swap16(xpos);
  ypos := Swap16(ypos);
  width := Swap16(width);
  height := Swap16(height);
  Listbox1.Items.Add(IntToStr(xpos)+' '+IntToStr(ypos)+' '+IntToStr(width)+''+IntToStr(height));
  processRequest(AThread);
end;

procedure TForm1.processRequest(AThread: TIdPeerThread);
// take a screenshot
// (while testing, put it into Image1)
var
  Width,Height : Word;
  SrcWindow: THandle;
  SrcDC: HDC;
  Bitmap: TBitmap;
begin
  SrcWindow:= GetDesktopWindow;
  if SrcWindow <> 0 then
  begin
    SrcDC:= GetDC(SrcWindow);
    if SrcDC <> 0 then
    begin
      Bitmap:= TBitmap.Create;
      Width := GetSystemMetrics(SM_CXSCREEN);
      Height := GetSystemMetrics(SM_CYSCREEN);
      Bitmap.Width:= Width div 4;
      Bitmap.Height:= Height div 4;
      StretchBlt(Image1.Canvas.Handle,0,0,Bitmap.Width,Bitmap.Height,
        SrcDC,0,0,Width,Height,SRCCOPY);
    end;
    ReleaseDC(SrcWindow,SrcDC);
    updateIsAvailable := True;
  end;
end;

procedure TForm1.readKeyEvent(AThread: TIdPeerThread);
var
  downFlag: byte;
  padding: byte;
  keyCode: Cardinal;
begin
  AThread.Connection.ReadBuffer(downFlag,1);
  AThread.Connection.ReadBuffer(padding,2);
  AThread.Connection.ReadBuffer(keyCode,4);
end;

procedure TForm1.readPointerEvent(AThread: TIdPeerThread);
var
  buttonMask: byte;
  xpos, ypos: Word;
begin
  AThread.Connection.ReadBuffer(buttonMask,1);
  AThread.Connection.ReadBuffer(xpos,2);
  AThread.Connection.ReadBuffer(ypos,2);
  // swap bytes
  xpos := Swap16(xpos);
  ypos := Swap16(ypos);
  Listbox1.Items.Add('x:'+IntToStr(xpos)+' y:'+IntToStr(ypos))
end;

procedure TForm1.readClientCutText(AThread: TIdPeerThread);
var
  padding: byte;
  txtLength: Cardinal;
  text: String;
begin
  AThread.Connection.ReadBuffer(padding,3);
  AThread.Connection.ReadBuffer(txtLength,4);
  AThread.Connection.ReadBuffer( {U8Array} text,1);
end;

procedure TForm1.writeServerInit(AThread: TIdPeerThread);
var
  desktopName : String;
  var x,y : Word;
begin
  desktopName := 'Hello World';

  // get screen dimension and swap bytes, because client expect high byte first
  x := GetSystemMetrics(SM_CXSCREEN);
  y := GetSystemMetrics(SM_CYSCREEN);
  //  x := Swap(x);
  //  y := Swap(y);
  x := Swap16(x);
  y := Swap16(y);

  // send framebuffer dimensions
  AThread.Connection.WriteBuffer(x, 2, True);
  AThread.Connection.WriteBuffer(y, 2, True);

  // PreferredPixelFormat
  ServerPixelFormat.BitsPerPixel := 16;
  ServerPixelFormat.depth := 16;
  ServerPixelFormat.BigEndianFlag := 0;
  ServerPixelFormat.TrueColourFlag := 1;
  AThread.Connection.WriteBuffer(ServerPixelFormat, 16, True);

  // Desktopname Length
  AThread.Connection.WriteCardinal(length(desktopName));

  // Desktop Name
  AThread.Connection.Write(desktopName);
end;

function TForm1.authenticate(AThread: TIdPeerThread):Boolean;
var AUTH_NUM, ClientAuth: Byte;
challengeQuestion: array[1..16] of Byte;
challengeAnswer: array[1..16] of Byte;
begin
  // send 1 authentication (Version 3.8)
  AUTH_NUM := 1;
  AThread.Connection.WriteBuffer(AUTH_NUM,1, True);
  AThread.Connection.WriteBuffer(VncAuth,1, True);
  AThread.Connection.ReadBuffer(ClientAuth,1);
  Label1.Caption := 'VNC auth: ' + IntToStr(ClientAuth);
  If ClientAuth = 2 then
  begin
    AThread.Connection.WriteBuffer(challengeQuestion,16, True);
    AThread.Connection.ReadBuffer(challengeAnswer,16);
    // for now, we do not check
    AThread.Connection.WriteBuffer(VncAuthOK,4, True);
  end;
  Result := true;
end;

procedure TForm1.doFrameBufferUpdate(AThread: TIdPeerThread);
// we still have framebuffer data to send to a client...
// (to be implemented...)
//
begin
  Listbox1.Items.Add('have FrameBuffer ready here...');
// all data sent? then updateIsAvailable := False;
end;

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
input: Byte;
msgStr: String;
begin
  // Loop
  writeProtocolVersionMsg(AThread);
  readProtocolVersionMsg(AThread);
  if (authenticate(AThread)) then begin {} end;
  readClientInit(AThread);
  initServer(AThread);
  writeServerInit(AThread);
  // start loop while client connected
  while not AThread.Terminated do
  begin
    if updateIsAvailable then doFrameBufferUpdate(AThread);
    //
    AThread.Connection.ReadBuffer(input,1);
    case input of
    SetPixelFormat:
      begin
      msgStr := 'SetPixelFormat';
      readSetPixelFormat(AThread);
      end;

    FixColourMapEntries:
      begin
      msgStr := 'FixColourMapEntries';
      readFixColourMapEntries(AThread);
      end;

    SetEncodings:
      begin
      msgStr := 'SetEncodings';
      readSetEncodings(AThread);
      end;

    FrameBufferUpdateRequest:
      begin
      msgStr := 'FrameBufferUpdateRequest';
      readFrameBufferUpdateRequest(AThread);
      end;

    KeyEvent:
      begin
      msgStr := 'KeyEvent';
      readKeyEvent(AThread);
      end;

    PointerEvent:
      begin
      msgStr := 'PointerEvent';
      readPointerEvent(AThread);
      end;

    ClientCutText:
      begin
      msgStr := 'ClientCutText';
      readClientCutText(AThread);
      end;
      
    else
      msgStr := 'unknown message type'+IntToStr(input);
    end;

    Listbox1.Items.Add(msgStr);
  end;
end;

end.