Delphi: small VNC Server using Indy comps

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.