Windows message server and client

Ever wanted to centralize the communication between child forms and your main form? Or perhaps you have a MDI application and want to make it easier to deal with toolbar registration for your forms, or perhaps more sane communication between your threads and the main app?

Well, this is very neat unit i wrote some time back (its been collecting dust for a few years) that gives you both a message server and a client. It uses byterage (small unit, download from google code) to make passing “sane” data between the clients and the server. Copy, Paste & Enjoy!

I will probably make this a part of the byterage package in the future – and also add w3_callback to deal with the “connected” state-changes in a more graceful way.

  unit unit2;

  interface

  uses sysutils, classes, wintypes,
  messages, forms, brage;

  Const
  ERR_JL_MsgHandler_CanNotBeActive  = 'State can not be active';

  ERR_JL_MsgServer_ServerActive     = 'Server state can not be active';
  ERR_JL_MsgServer_ServerNotActive  = 'Server state must be active';

  ERR_JL_MsgClient_FailedResolve    = 'Failed to resolve message host';
  ERR_JL_MsgClient_FailedConnect    = 'Connection failed';

  Const
  JL_MESSAGESERVER_PREFIX  = 'JLMSVR:';

  (* messages used to establish server instances and availability *)
  Const
  WM_SERVER_PONG          = 1;
  WM_SERVER_PING          = 0;

  (* messages clients send to servers *)
  Const
  WM_CLIENT_CONNECT       = WM_USER + 65790;
  WM_CLIENT_DISCONNECT    = WM_USER + 65791;
  WM_CLIENT_DELIVER       = WM_USER + 65792;

  (* messages servers send back to clients *)
  Const
  WM_SERVER_DISCONNECT    = WM_USER + 65795;
  WM_SERVER_CONNECTED     = WM_USER + 65796;
  WM_SERVER_DELIVERED     = WM_USER + 65797;
  WM_SERVER_DELIVER       = WM_USER + 65798;

  type

  {TJLMsgReader = Class;
  TJLMsgWriter = Class;  }

  (* exception classes *)
  EJLMsgServer = Class(Exception);
  EJLMsgClient = Class(Exception);

  TJLMsgHandle  = HWND;

  (* Message Server Events *)
  TJLMsgServerClientConnectEvent
  = Procedure (Sender:TObject;AHandle:TJLMsgHandle) of Object;

  TJLMsgServerClientDisconnectEvent
  = Procedure (Sender:TObject;AHandle:TJLMsgHandle) of Object;

  TJLMsgServerRecievedEvent
  = Procedure (Sender:TObject;Const Request:TBRReader;
  Const Response:TBRWriter) of Object;

  (* Message Client events *)
  TJLMsgClientRecievedEvent
  = Procedure (Sender:TObject;Const Request:TBRReader) of Object;

  (* internal data packet used to transport data between processes *)
  PJLMessageData = ^TJLMessageData;
  TJLMessageData = Record
    mdSenderHandle:         TJLMsgHandle;
    mdFrequency:            Integer;
    mdDeliveryNotification: Boolean;
    mdData:                 Pointer;
    mdBytes:                Integer;
  End;

  TJLMsgEvents =  Set of (meBeforeOpen,meAfterOpen,meBeforeClose,
                    meAfterClose,meOpen,meClose,meMessage);

  TJLMsgOptions = set of (moEncryption);

  TJLMsgHandler = Class(TComponent)
  Private
    FActive:      Boolean;
    FWinhandle:   TJLMsgHandle;
    FOnBefOpen:   TNotifyEvent;
    FOnAftOpen:   TNotifyEvent;
    FOnBefClose:  TNotifyEvent;
    FOnAftClose:  TNotifyEvent;
    FOnOpen:      TNotifyEvent;
    FOnClose:     TNotifyEvent;
    FEvents:      TJLMsgEvents;
    FOptions:     TJLMsgOptions;
    Procedure     SetActive(Const Value:Boolean);
    Procedure     SetOptions(Const Value:TJLMsgOptions);
  Protected
    Procedure     SendToDefaultHandler(var Msg:TMessage);
    Procedure     WndProc(var msg: TMessage);virtual;
    Procedure     DoBeforeOpen;
    Procedure     DoAfterOpen;
    Procedure     DoBeforeClose;
    procedure     DoAfterClose;
    Procedure     SessionBegins;virtual;
    Procedure     SessionEnds;virtual;
    Procedure     DoOpen;
    Procedure     DoClose;
  Public
    Property      Options: TJLMsgOptions read FOptions write SetOptions;

    Property      Events:TJLMsgEvents read FEvents write FEvents;
    property      OnOpened:TNotifyEvent
                  Read FOnOpen write FOnOpen;
    Property      OnClosed:TNotifyEvent
                  Read FOnClose write FOnClose;
    Property      OnBeforeOpen:TNotifyEvent
                  Read FOnBefOpen write FOnBefOpen;
    Property      OnBeforeClose:TNotifyEvent
                  Read FOnBefClose write FOnBefClose;
    Property      OnAfterOpen:TNotifyEvent
                  Read FOnAftOpen write FOnAftOpen;
    Property      OnAfterClose:TNotifyEvent
                  Read FOnAftClose write FOnAftClose;
    Property      Handle: TJLMsgHandle read FWinHandle;
    Property      Active:Boolean read FActive write SetActive;
    Procedure     Open;virtual;
    procedure     Close;virtual;
    procedure     Loaded;Override;
    Constructor   Create(AOwner:TComponent);override;
    Procedure     BeforeDestruction;Override;
  End;

  {
  TJLMsgReader = Class(TObject)
  Private
    FData:      TStream;
    FSender:    TJLMsgHandle;
    Function    GetSize:Integer;
  Public
    Property    Sender:TJLMsgHandle read FSender;
    Property    Size:Integer read GetSize;
    Function    Read(var outData;Const outBytes:Integer):Boolean;
    Constructor Create(Const inStream:TStream;Const inSender:TJLMsgHandle);
  End;

  TJLMsgWriter = Class(TObject)
  Private
    FData:      TStream;
    FReciever:  TJLMsgHandle;
  Public
    Property    Reciever:TJLMsgHandle read FReciever;
    Procedure   Write(var inData;Const inBytes:Integer);
    Constructor Create(Const outStream:TStream;Const inReciever:TJLMsgHandle);
  End;       }

  TJLMsgServer = Class(TJLMsgHandler)
  Private
    FServer:      String;
    FAppName:     String;
    FFrequency:   Integer;
    FOnConnect:   TJLMsgServerClientConnectEvent;
    FOnDisConnect:TJLMsgServerClientDisconnectEvent;
    FOnMessage:   TJLMsgServerRecievedEvent;
    FSysMessage:  Cardinal;
    FOwnsMessage: Boolean;
    FClients:     TList;
  Private
    Procedure     SetFrequency(Const Value:Integer);
    Procedure     SetServerName(Const Value:String);
    Procedure     SetSoftwareName(Const Value:String);
    Function      GetFrequency:Integer;
    Function      GetServerName:String;
    Function      GetSoftwareName:String;
    Function      GetCount:Integer;
    Function      GetItem(Const Index:Integer):TJLMsgHandle;
  Protected
    Procedure     SessionBegins;override;
    Procedure     SessionEnds;override;
    Procedure     WndProc(var msg: TMessage);override;
  Public
    Property      Count:Integer read GetCount;
    Property      Items[Const Index:Integer]:TJLMsgHandle read GetItem;
    Procedure     DisconnectAll;
    Procedure     Disconnect(Const Client:TJLMsgHandle);
    Procedure     BroadCast(Const Exclude:TJLMsgHandle;var Data;Const Bytes:Integer);
    Procedure     Write(Const Reciever:TJLMsgHandle;var Data;Const Bytes:Integer);
  Published
    Property      Active;
    Property      OnOpened;
    Property      OnClosed;
    Property      OnBeforeOpen;
    Property      OnBeforeClose;
    Property      OnAfterOpen;
    Property      OnAfterClose;
    Property      Events;
    Property      Options;

    Property      OnClientConnect:TJLMsgServerClientConnectEvent
                  read FOnConnect write FOnConnect;

    Property      OnClientDisconnect:TJLMsgServerClientDisconnectEvent
                  read FOnDisconnect write FOnDisconnect;

    property      OnMessage:TJLMsgServerRecievedEvent
                  read FOnMessage write FOnMessage;

    Property      ServerName:String
                  read GetServerName write SetServerName;

    Property      Software:String
                  read GetSoftwareName write SetSoftwareName;

    Property      Frequency:Integer
                  read GetFrequency write SetFrequency;

    Constructor   Create(AOwner:TComponent);override;
    Destructor    Destroy;Override;
  End;

  TJLMsgClient = Class(TJLMsgHandler)
  Private
    FServer:          String;
    FFrequency:       Integer;
    FSYSMESSAGE:      Cardinal;
    FOnline:          Boolean;
    FConnected:       Boolean;
    FServerHandle:    TJLMsgHandle;
    FMemPool:         TList;
    FOnMessage:       TJLMsgClientRecievedEvent;
    Procedure         ClearMemPool;
    Procedure         Write(var Data;Const Bytes:Integer;
                      Const Blocking:Boolean=False);
  Private
    Procedure         SetServer(Const Value:String);
    Procedure         SetFrequency(Const Value:Integer);
    Function          ResolveServer(var outError:String):Boolean;
    Function          GetFullServerName:String;
  Protected
    Procedure         WndProc(var msg: TMessage);override;
    Procedure         SessionBegins;override;
    Procedure         SessionEnds;override;
  Public
    Property          FullServerName:String read GetFullServerName;
    Property          ServerHandle: TJLMsgHandle read FServerHandle;
    Procedure         Close;Override;

    Function          BeginWrite(var outWriter:TBRWriter):Boolean;
    Procedure         EndWrite(Const Writer:TBRWriter);

    Constructor       Create(AOwner:TComponent);Override;
    Destructor        Destroy;Override;
  Published
    Property          Active;
    Property          OnOpened;
    Property          OnClosed;
    Property          OnBeforeOpen;
    Property          OnBeforeClose;
    Property          OnAfterOpen;
    Property          OnAfterClose;
    Property          Events;
    Property          Options;
    Property          ServerName:String read FServer write SetServer;
    Property          Frequency:Integer read FFrequency write SetFrequency;
    Property          OnMessage:TJLMsgClientRecievedEvent
                      read FOnMessage write FOnMessage;
  End;

  implementation

  //##########################################################################
  // TJLMsgClient
  //##########################################################################

  Constructor TJLMsgClient.Create(AOwner:TComponent);
  Begin
    inherited;
    FMemPool:=TList.Create;
    FServer:='JLSvr';
    FFrequency:=65536;
  end;

  Destructor TJLMsgClient.Destroy;
  Begin
    ClearMemPool;
    FMemPool.free;
    inherited;
  end;

  Procedure TJLMsgClient.ClearMemPool;
  Begin
    While FMemPool.Count>0 do
    Begin
      FreeMem(FMemPool[0]);
      FMemPool.Delete(0);
    end;
  end;

  Procedure TJLMsgClient.Close;
  Begin
    If Active then
    PostMessage(FServerHandle,FSYSMESSAGE,
    WM_CLIENT_DISCONNECT,Handle);
    inherited;
  end;

  Procedure TJLMsgClient.SetServer(Const Value:String);
  Begin
    If (csLoading in ComponentState)
    or (csDesigning in ComponentState) then
    FServer:=trim(Value) else
    If not Active then
    FServer:=trim(Value);
  end;

  Procedure TJLMsgClient.SetFrequency(Const Value:Integer);
  Begin
    If (csLoading in ComponentState)
    or (csDesigning in ComponentState) then
    FFrequency:=Value else
    Begin
      If not Active then
      FFrequency:=Value;
    end;
  end;

  Function TJLMsgClient.GetFullServerName:String;
  Begin
    If Active then
    Result:=Uppercase(JL_MESSAGESERVER_PREFIX + FServer
    + ':' + IntToStr(FFrequency)) else
    result:='';
  end;

  Function TJLMsgClient.BeginWrite(var outWriter:TBRWriter):Boolean;
  var
    FData:    TStream;
    FWriter:  TBRWriterStream;
  Begin
    result:=False;
    outWriter:=NIL;

    try
      FData:=TMemoryStream.Create;
    except
      on exception do
      exit;
    end;

    try
      FWriter:=TBRWriterStream.Create(FData);
    except
      on exception do
      Begin
        FreeAndNil(FData);
        exit;
      end;
    end;

    outWriter:=FWriter;
    result:=True;
  end;

  Procedure TJLMsgClient.EndWrite(Const Writer:TBRWriter);
  var
    FData:  TMemoryStream;
  Begin
    If  (Writer<>NIL)
    and (Writer is TBRWriterStream) then
    Begin
      FData:=TMemoryStream(TBRWriterStream(Writer).DataStream);
      try
        FData.Position:=0;
        Write(FData.Memory^,FData.Size);
      finally
        Writer.free;
        FData.free;
      end;
    end;
  end;

  Procedure TJLMsgClient.Write(var Data;Const Bytes:Integer;
            Const Blocking:Boolean=False);
  var
    FMessage: PJLMessageData;
  Begin
    if Active then
    Begin
      If Bytes>0 then
      Begin
        If not (csDesigning in ComponentState) then
        Begin
          New(FMessage);
          FMessage^.mdSenderHandle:=Handle;
          FMessage^.mdFrequency:=FFrequency;
          FMessage^.mdBytes:=Bytes;
          FMessage^.mdData:=AllocMem(Bytes);
          Move(Data,FMessage^.mdData^,Bytes);

          If Blocking then
          Begin
            (* set owned-data to false *)
            FMessage^.mdDeliveryNotification:=False;

            (* send message & wait for response *)
            SendMessage(FServerHandle,FSYSMESSAGE,
            WM_CLIENT_DELIVER,Integer(FMessage));

            (* release memory allocation *)
            FreeMem(Fmessage^.mdData);

            (* dispose of message *)
            Dispose(FMessage);
          end else
          Begin
            (* Add Memory Allocation to memory pool *)
            FMemPool.Add(FMessage^.mdData);

            (* set owned-data to true *)
            FMessage^.mdDeliveryNotification:=True;

            (* send the message away *)
            Postmessage(FServerHandle,FSYSMESSAGE,
            WM_CLIENT_DELIVER,Integer(FMessage));
          end;
        end;
      end;
    end;
  end;

  Procedure TJLMsgClient.WndProc(var msg: TMessage);
  var
    FMessage: PJLMessageData;
    FIndex:   Integer;
    FIn:      TMemoryStream;
    FReq:     TBRReaderStream;
  Begin
    If msg.Msg=FSYSMESSAGE then
    Begin
      msg.Result:=1;
      Case msg.WParam of
      WM_SERVER_PONG:
        Begin
          FServerHandle:=msg.LParam;
          FOnline:=True;
        end;
      WM_SERVER_DISCONNECT:
        Begin
          if msg.LParam<>0 then
          Begin
            FMessage:=Pointer(msg.LParam);
            If FMessage^.mdFrequency=FFrequency then
            Begin
              If Active then
              Close;
            end;
          end;
        end;
      WM_SERVER_CONNECTED:    FConnected:=True;
      WM_SERVER_DELIVERED:
        Begin
          If msg.LParam<>0 then
          Begin
            FMessage:=Pointer(msg.LParam);
            If FMessage^.mdData<>NIL then
            Begin
              FIndex:=FMemPool.IndexOf(FMessage^.mdData);
              If FIndex>=0 then
              Begin
                FreeMem(FMemPool[FIndex]);
                FmemPool.Delete(FIndex);
              end;
            end;
            Dispose(FMessage);
          end;
        end;
      WM_SERVER_DELIVER:
        Begin
          If msg.LParam<>0 then
          Begin
            FMessage:=Pointer(msg.LParam);

            If (meMessage in Events) then
            Begin
              If assigned(FOnMessage) then
              Begin
                If FMessage.mdSenderHandle=FServerHandle then
                Begin
                  FIn:=TMemoryStream.Create;
                  try
                    FIn.WriteBuffer(FMessage^.mdData^,FMessage^.mdBytes);
                    FIn.Position:=0;

                    //FReq:=TJLMsgReader.Create(FIn,FMessage^.mdSenderHandle);
                    FReq:=TBRReaderStream.Create(FIn);
                    try
                      FOnMessage(self,FReq);
                    finally
                      FReq.Free;
                    end;

                  finally
                    FIn.free;
                  end;
                end;
              end;
            end;
          end;
        end;
      else
        SendToDefaultHandler(msg);
      end;
    end else
    Inherited;
  end;

  Function TJLMsgClient.ResolveServer(var outError:String):Boolean;
  var
    FToken:   String;
    x:        Integer;
  begin
    (* as far as we know, there can be other instances of this server name  *)
    FOnline:=False;

    (*  use the servername to register for a unique message.
        if this is already taken, then the message will directly to that
        server *)
    FToken:=uppercase(JL_MESSAGESERVER_PREFIX + FServer);
    FSysMessage:=RegisterWindowMessage(PChar(FToken));

    (* send out a blocking PING, if we recieve a PONG response, then
       we can connect to the server *)
    //SendMessage(HWND_BROADCAST,FSYSMESSAGE,WM_SERVER_PING,Handle);
    PostMessage(HWND_BROADCAST,FSYSMESSAGE,WM_SERVER_PING,Handle);

    for x:=1 to 20 do
    Begin
      sleep(20);
      Application.ProcessMessages;
      If FOnline then
      Break;
    end;

    (*  if some other server sent a pong message back, then we know we
        have other instances hosting the server name *)
    Result:=FOnline;
    If not Result then
    outError:=ERR_JL_MsgClient_FailedResolve;
  end;

  Procedure TJLMsgClient.SessionBegins;
  var
    FMessage: TJLMessageData;
    FError:   String;
    x:        Integer;
  Begin
    (* Resolve server *)
    If not ResolveServer(FError) then
    Begin
      Close;
      Raise EJLMsgClient.Create(FError);
    end;

    (* send a connect request *)
    FConnected:=False;
    FMessage.mdSenderHandle:=Handle;
    FMessage.mdFrequency:=FFrequency;
    Fmessage.mdData:=NIL;

    PostMessage(FServerHandle,FSYSMESSAGE,
    WM_CLIENT_CONNECT,Integer(@FMessage));

    for x:=1 to 10 do
    Begin
      sleep(10);
      Application.ProcessMessages;
    end;

    (* not connected? Shut down*)
    If not FConnected then
    Begin
      Close;
      Raise EJLMsgClient.Create
      (ERR_JL_MsgClient_FailedConnect);
    end;
    DoOpen;
  end;

  Procedure TJLMsgClient.SessionEnds;
  Begin
    FConnected:=False;
    FServerHandle:=0;
    FOnline:=False;
    ClearMemPool;
    DoClose;
  end;

  //##########################################################################
  // TJLMsgServer
  //##########################################################################

  Constructor TJLMsgServer.Create(AOwner:TComponent);
  Begin
    inherited;
    FClients:=TList.Create;
    FServer:='JLSvr';
    FAppName:='Unknown';
    FFrequency:=65536;
  end;

  Destructor TJLMsgServer.Destroy;
  begin
    FClients.free;
    inherited;
  end;

  Function TJLMsgServer.GetCount:Integer;
  Begin
    result:=FClients.Count;
  end;

  Function TJLMsgServer.GetItem(Const Index:Integer):TJLMsgHandle;
  Begin
    Result:=TJLMsgHandle(FClients[index]);
  end;

  Procedure TJLMsgServer.SessionBegins;
  var
    FToken:   String;
    x:        Integer;
  begin
    (* as far as we know, there can be other instances of this server name  *)
    FOwnsMessage:=False;

    (*  use the servername to register for a unique message.
        if this is already taken, then the message will direct to that
        server *)
    FToken:=Uppercase(JL_MESSAGESERVER_PREFIX + FServer);
    FSysMessage:=RegisterWindowMessage(PChar(FToken));

    (* send out a test signal, if we recieve it in our messagehandler,
        and the handle is our own - then we know we are alone *)
    Postmessage(HWND_BROADCAST,FSYSMESSAGE,0,Handle);

    for x:=1 to 20 do
    Begin
      sleep(20);
      Application.ProcessMessages;
      If FOwnsMessage then
      Break;
    end;

    (*  if some other server sent a pong message back, then we know we
        have other instances alive with this message *)
    If not FOwnsMessage then
    Begin
      Close;
      Raise Exception.Create('A server with this name is already running error');
    end;

    inherited;
  end;

  Procedure TJLMsgServer.SessionEnds;
  Begin
    inherited;
  end;

  Function TJLMsgServer.GetFrequency:Integer;
  Begin
    Result:=FFrequency;
  end;

  Function TJLMsgServer.GetServerName:String;
  Begin
    Result:=FServer;
  end;

  Function TJLMsgServer.GetSoftwareName:String;
  Begin
    result:=FAppName;
  end;

  Procedure TJLMsgServer.SetFrequency(Const Value:Integer);
  Begin
    If Value<>FFrequency then
    Begin
      If (csLoading in ComponentState)
      or (csDesigning in ComponentState) then
      FFrequency:=Value else
      Begin
        If Active then
        Raise EJLMsgServer.Create(ERR_JL_MsgServer_ServerActive) else
        FFrequency:=Value;
      end;
    end;
  end;

  Procedure TJLMsgServer.SetSoftwareName(Const Value:String);
  Begin
    If Value<>FAppName then
    Begin
      If (csLoading in ComponentState)
      or (csDesigning in ComponentState) then
      FAppName:=Value else
      Begin
        If Active then
        Raise EJLMsgServer.Create(ERR_JL_MsgServer_ServerActive) else
        FAppName:=Value;
      end;
    end;
  end;

  Procedure TJLMsgServer.SetServerName(Const Value:String);
  Begin
    If Value<>FServer then
    Begin
      If (csLoading in ComponentState)
      or (csDesigning in ComponentState) then
      FServer:=Value else
      Begin
        If Active then
        Raise EJLMsgServer.Create(ERR_JL_MsgServer_ServerActive) else
        FServer:=Value;
      end;
    end;
  end;

  Procedure TJLMsgServer.DisconnectAll;
  Begin
  end;

  Procedure TJLMsgServer.Disconnect(Const Client:TJLMsgHandle);
  Begin
  end;

  Procedure TJLMsgServer.BroadCast(Const Exclude:TJLMsgHandle;var Data;
            Const Bytes:Integer);
  var
    z:        Integer;
    FHandle:  TJLMsgHandle;
  Begin
    If Active then
    Begin
      If not (csDesigning in ComponentState) then
      Begin
        If FClients.Count>0 then
        Begin
          for z:=1 to FClients.Count do
          Begin
            FHandle:=Integer(FClients[z-1]);
            if FHandle<>Exclude then
            Write(FHandle,data,bytes);
          end;
        end;
      end;
    end else
    Raise EJLMsgServer.Create(ERR_JL_MsgServer_ServerNotActive);
  end;

  Procedure TJLMsgServer.Write(Const Reciever:TJLMsgHandle;
            var Data;Const Bytes:Integer);
  var
    FMessage: TJLMessageData;
  Begin
    If Active then
    Begin
      If not (csDesigning in ComponentState) then
      Begin
        If FClients.IndexOf(pointer(Reciever))>=0 then
        Begin
          FMessage.mdSenderHandle:=Handle;
          FMessage.mdFrequency:=FFrequency;
          FMessage.mdDeliveryNotification:=False;
          FMessage.mdData:=@Data;
          FMessage.mdBytes:=Bytes;
          SendMessage(Reciever,FSYSMESSAGE,
          WM_SERVER_DELIVER,Integer(@FMessage));
        end;
      end;
    end else
    Raise EJLMsgServer.Create(ERR_JL_MsgServer_ServerNotActive);
  end;

  Procedure TJLMsgServer.WndProc(var msg: TMessage);
  var
    FMessage:   PJLMessageData;
    FIndex:     Integer;
    FIn,FOut:   TMemoryStream;
    FReq:       TBRReader;
    FRes:       TBRWriter;
  Begin
    msg.Result:=0;
    If not (csDestroying in ComponentState) then
    Begin

    If msg.Msg=FSYSMESSAGE then
    Begin
      Case msg.WParam of
      WM_SERVER_PONG: FOwnsMessage:=TJLMsgHandle(msg.LParam)=Handle;
      WM_SERVER_PING:
        Begin
          If TJLMsgHandle(msg.LParam)<>Handle then
          SendMessage(msg.LParam,FSYSMESSAGE,WM_SERVER_PONG,Handle) else
          FOwnsMessage:=True;
        end;
      WM_CLIENT_CONNECT:
        Begin
          If msg.LParam<>0 then
          Begin
            FMessage:=Pointer(msg.LParam);
            If FMessage.mdFrequency=FFrequency then
            Begin
              If FClients.IndexOf(pointer(FMessage^.mdSenderHandle))=-1 then
              Begin
                FClients.Add(Pointer(FMessage^.mdSenderHandle));
                SendMessage(FMessage^.mdSenderHandle,
                FSYSMESSAGE,WM_SERVER_CONNECTED,0);
                If assigned(FOnConnect) then
                FOnConnect(self,FMessage^.mdSenderHandle);
              end;
            end;
          end;
        end;
      WM_CLIENT_DISCONNECT:
        Begin
          If msg.LParam<>0 then
          Begin
            FIndex:=FClients.IndexOf(pointer(msg.LParam));
            If FIndex>=0 then
            Begin
              FClients.Delete(FIndex);
              if assigned(FOnDisConnect) then
              FOnDisconnect(self,msg.LParam);
            end;
          end;
        end;
      WM_CLIENT_DELIVER:
        Begin
          If msg.LParam<>0 then
          Begin
            FMessage:=Pointer(msg.LParam);
            If FMessage^.mdFrequency=FFrequency then
            Begin

              If (meMessage in Events) then
              If assigned(FOnMessage) then
              Begin
                FIn:=TMemoryStream.Create;
                try
                  FOut:=TMemoryStream.Create;
                  try
                    FIn.WriteBuffer(FMessage^.mdData^,FMessage.mdBytes);
                    FIn.Position:=0;

                    FReq:=TBRReaderStream.Create(FIn); //,FMessage^.mdSenderHandle
                    try
                      FRes:=TBRWriterStream.Create(Fout); //,FMessage^.mdSenderHandle
                      try
                        If assigned(FOnMessage) then
                        FOnMessage(self,FReq,FRes);

                        (* send reply *)
                        if FOut.Size>0 then
                        Begin
                          FOut.Position:=0;
                          Write(FMessage^.mdSenderHandle,FOut.Memory^,
                          FOut.Size);
                        end;

                      finally
                        FRes.free;
                      end;
                    finally
                      FReq.free;
                    end;
                  finally
                    FOut.free;
                  end;
                finally
                  FIn.free;
                end;
              end;

              (* the data memory is bound to the sender, we must
                  return a packet so it can be released in
                  its own process space *)
              If Fmessage^.mdDeliveryNotification then
              PostMessage(Fmessage^.mdSenderHandle,
              FSYSMESSAGE,WM_SERVER_DELIVERED,msg.LParam);
            end;
          end;
        end;
      end;
    end else
    Inherited;

    end;
  end;

  //##########################################################################
  // TJLMsgHandler
  //##########################################################################

  Constructor TJLMsgHandler.Create(AOwner:TComponent);
  Begin
    inherited;
    FEvents:=[meBeforeOpen,meAfterOpen,meBeforeClose,
    meAfterClose,meOpen,meClose,meMessage];
  end;

  Procedure TJLMsgHandler.BeforeDestruction;
  Begin
    If FActive then
    Close;
    inherited;
  end;

  procedure TJLMsgHandler.Loaded;
  Begin
    inherited;
    If (FActive=True) and (FWinhandle=0) then
    Begin
      FActive:=False;
      Open;
    end;
  end;

  Procedure TJLMsgHandler.SessionBegins;
  Begin
    DoOpen;
  end;

  Procedure TJLMsgHandler.SessionEnds;
  Begin
    DoClose;
  end;

  Procedure TJLMsgHandler.DoOpen;
  Begin
    If  not (csDestroying in ComponentState)
    and assigned(FOnOpen)
    and (meOpen in FEvents) then
    FOnOpen(self);
  end;

  Procedure TJLMsgHandler.DoClose;
  Begin
    If  not (csDestroying in ComponentState)
    and assigned(FOnClose)
    and (meClose in FEvents) then
    FOnClose(self);
  end;

  Procedure TJLMsgHandler.DoBeforeOpen;
  Begin
    If not (csDestroying in ComponentState)
    and assigned(FOnBefOpen)
    and (meBeforeOpen in FEvents) then
    FOnBefOpen(self);
  end;

  Procedure TJLMsgHandler.DoAfterOpen;
  Begin
    If not (csDestroying in ComponentState)
    and assigned(FOnAftOpen)
    and (meAfterOpen in FEvents) then
    FOnAftOpen(self);
  end;

  Procedure TJLMsgHandler.DoBeforeClose;
  Begin
    If not (csDestroying in ComponentState)
    and assigned(FOnBefClose)
    and (meBeforeClose in FEvents) then
    FOnBefClose(self);
  end;

  procedure TJLMsgHandler.DoAfterClose;
  Begin
    If not (csDestroying in ComponentState)
    and assigned(FOnAftClose)
    and (meAfterClose in FEvents) then
    FOnAftClose(self);
  end;

  Procedure TJLMsgHandler.SendToDefaultHandler(var Msg:TMessage);
  Begin
    msg.Result := DefWindowProc(FWinHandle,Msg.Msg,Msg.wParam,Msg.lParam);
  end;

  procedure TJLMsgHandler.WndProc(var msg: TMessage);
  begin
    (* this is an ancestor class, so we let windows handle the message *)
    SendToDefaultHandler(msg);
  end;

  Procedure TJLMsgHandler.SetActive(Const Value:Boolean);
  Begin
    If Value<>FActive then
    Begin
      If Value then
      Open else
      Close;
    end;
  end;

  Procedure TJLMsgHandler.Open;
  Begin
    If not FActive then
    Begin
      FActive:=True;
      If not (csDesigning in ComponentState)
      and not (csLoading in ComponentState) then
      Begin
        DoBeforeOpen;
        {$warnings off}
        FWinHandle := AllocateHWND(WndProc);
        {$warnings on}
        SessionBegins;
        DoAfterOpen;
      End;
    end;
  end;

  Procedure TJLMsgHandler.SetOptions(Const Value:TJLMsgOptions);
  Begin
    If Value<>FOptions then
    Begin
      If (csLoading in ComponentState)
      or (csDesigning in ComponentState) then
      FOptions:=Value else
      Begin
        If Active then
        Raise EJLMsgServer.Create(ERR_JL_MsgHandler_CanNotBeActive) else
        FOptions:=Value;
      end;
    end;
  end;

  procedure TJLMsgHandler.Close;
  var
    Instance: Pointer;
  Begin
    If FActive then
    Begin
      FActive:=False;
      If not (csDesigning in ComponentState)
      and not (csLoading in ComponentState) then
      Begin
        DoBeforeClose;
        Instance := Pointer(GetWindowLong(FWinHandle, GWL_WNDPROC));
        if Instance <> @DefWindowProc then
        begin
          SetWindowLong(FWinHandle, GWL_WNDPROC, Longint(@DefWindowProc));
          {$warnings off}
          FreeObjectInstance(Instance);
          {$warnings on}
        end;
        DestroyWindow(FWinHandle);
        FWinHandle:=0;
        SessionEnds;
        DoAfterClose;
      end;
    end;
  end;

  end.

Storing TControlbar child positions

I have seen people ask about this since Windows XP was hot, so here (drumroll) is how you save the position of the bars inside a TControlbar control. And also a perfect example of how useful class helpers are 🙂

Controlbars are neat

Just put the code inside it’s own unit, add a reference to the unit in your form – and voila “loadfromstream” and “savetostream” can be used to store the positions of child controls to a stream.

  TControlBarHelper = Class helper for TControlBar
  public
    Procedure SaveToStream(aStream:TStream);
    Procedure LoadFromStream(aStream:TStream);
  End;

procedure TControlBarHelper.LoadFromStream(aStream: TStream);
var
  x:  Integer;
  mReader:  TReader;
  mName:  String;
  mObj: TControl;
begin
  if aStream<>NIL then
  begin
    mReader:=TReader.Create(aStream,1024);
    try
      if mReader.ReadInteger=$BABE then
      Begin
        x:=mReader.ReadInteger;
        while x>0 do
        begin
          mName:=mReader.ReadString;
          mObj:=FindChildControl(mName);
          if mObj<>NIL then
          begin
            with mReader do
            Begin
              mObj.Left:=ReadInteger;
              mObj.Top:=ReadInteger;
              mObj.Width:=ReadInteger;
              mObj.Height:=ReadInteger;
            end;
          end;
          dec(x);
        end;
      end else
      Raise Exception.Create
      ('Failed to read controlbar, header not recognized error');
    finally
      mReader.Free;
    end;
  end else
  Raise Exception.Create
  ('Failed to load controlbar, source stream was NIL');
end;

procedure TControlBarHelper.SaveToStream(aStream: TStream);
var
  x:  Integer;
  mWriter:  TWriter;
begin
  if aStream<>NIL then
  begin
    mWriter:=TWriter.Create(aStream,1024);
    try
      mWriter.WriteInteger($BABE);
      mWriter.WriteInteger(self.ControlCount);
      for x:=0 to self.ControlCount-1 do
      Begin
        mWriter.WriteString(Controls[x].Name);
        mWriter.WriteInteger(Controls[x].Left);
        mWriter.WriteInteger(Controls[x].top);
        mWriter.WriteInteger(Controls[x].width);
        mWriter.WriteInteger(Controls[x].Height);
      end;
    finally
      mWriter.FlushBuffer;
      mWriter.Free;
    end;
  end else
  Raise Exception.Create
  ('Failed to store controlbar, target stream was NIL');
end;

Programmer testing miracle products, the green coffey diet!

Facebook and other media is packed to the brim with diets and products that are supposed to help with lose weight. They are so annoying that I decided to test and blog about one of them, because I firmly believe they are wrong. I find it so sad  that friends (primarily women) throw away money on these products, because ultimately, there is only one way to get a better body and that is to work out! So today I decided to give one of these miracle diets a critical, real-life test by a programmer which, in most likelihood, is used to be being far more critical than the aunts, cousins and sisters of this world.

But, I am going to be fair. If this works (which I highly doubt) I have agreed to wear “the norwegian pants” (google that) for a whole workday at the office. Although I don’t think that will happen anytime soon.

Or just work out for 1 hour a day…

What is acclaimed

According to the commercials (both the one circulating on Facebook, G+, radio and television) the 100% guaranteed results of taking 2 capsules of raw green-coffey a day, and im extrapolating from different sources here, are:

• Firmer breasts
• Tighter thighs (Robin hood style?)
• Lose at least 4 kilos of fat in 30 days (not body weight, but fat!)
• More energy
• Overall happier with less mood swings
• Less menstrual pain
• Smother and more vibrant skin

Initial thoughts

The concept of firmer breasts freaks me out right off the bat, but in the name of science and computing im willing to grow a pair for the team. Although it would be quite a miracle if i evolve a pair of knockers over the next month (and somewhat materials for a horror movie; pictures of the poor due in Fight Club immediately springs to mind).

The norwegian stuff

Also, the box contains 60 tablets – meaning a 30 day program – which incidentally means you violate the “trial” period of you actually complete the diet! Meaning of course that you wont get a penny back because your complaint is made on wrong assumptions.

Debugging the content

My first impression of this product is, naturally, that it contains quite high doses of caffeine. Which is known for the following effects:

• Tightens blood arteries, giving a false experience of firmness
• Causes the body to expel excess water
• Makes you feel more awake
• Is used in painkillers
• Causes the liver to produce more gall, leading to more acidic stomach content, which results in more frequent toilet visits

So to sum up, the product more or less promises to deliver exactly the same (if not less) than a cheaper off the shelf pre-workout formula!

Same effect, but this is what men buy

Be that as it may – the ad claims that you are to lose 4 kilos of fat, not water — so this will be interesting! Having taken 2 capsules I have already been to the toilet 2 times in 1 hour, so I know where this is going…

[To be continued..]

Using the crypt unit for something useful

Right, I posted the full crypto unit yesterday, but I didn’t have time to post an example of how to use it. So this time we are going to have some real-life practical examples.

How does this key stuff work?

We are all used to passwords and security these days, but there are a few things that have changed since the golden days of home-made services and DIY websites. Most notably is the fact that you should never store passwords at all. If you think back 5-8 years ago, it would have been perfectly valid for a webservice or a database driven website to store usernames and passwords in a database table. But should someone gain access to your database, they could in fact rob your database of passwords and ruin everything.

The solution? Dont store passwords. You store a hash of a password. A hash is just a number that is generated from analysing a piece of data, it’s sometimes also called a checksum. The important part about a hash is that it will generate the same number exclusively when the data matches. As you can imagine, it’s almost impossible to guess a password from a hash-number.

Another thing to note about key-pairs is that they are not designed to encrypt large sections of data. They are designed to encrypt small things (passwords) and have a limit ranging from 256 to 512 bytes – meaning somthing like 128 unicode characters. Encryption of files and streams is done by generating a hash from an encrypted password – and using that hash as the key for a common cipher like RC4 or Blowfish. These extra steps makes it more or less impossible to decode your data without the absolute and concrete original information.

Here is one way of generating a a portable, encrypted file:

• Generate a hash from a password
• Generate a cipher key-set
• Encrypt the hash using the public key
• Save the encrypted hash to the target-stream
• Save the public key to the target-stream
• Encrypt the password-hash using the private key
• Use encrypted hash as a key-stream for encrypting the “real” data
• Save encrypted data to the target-stream

This creates a dual-key lock. You need both the original private-key and password to decipher the data. Even if you steal the original key-set or gain the original password, the data remains useless without both. By de-coupling these two factors and only providing the public key, another person can only verify that the file belongs to you (by first generating a hash of your password, then decrypting the provided hash using the public key and comparing it), but you still cant read the content of such a file without the private key. This is more or less how secure document transportation works, where you can checkout a document anywhere in the world with a smart-card and personal password. The private key is stored on the card and without both items the data remains unreadable.

How you chose to play around with these schemes is up to you. In some cases rolling your own security is better than buying a solution, because the less that is known about a scheme – the harder it will be to crack.

Generating keys

To generate a key-pair you would write:

procedure TForm1.Button3Click(Sender: TObject);
var
  mPrivate: TStream;
  mPublic:  TStream;
  mTemp:  String;
begin
  if TCryptoAPI.rsaMakeKeys(mprivate,mPublic) then
  begin
    try
      if TCryptoAPI.rsaKeyToBase64(mPrivate,mTemp) then
      showmessage(mTemp);

      if TCryptoAPI.rsaKeyToBase64(mPublic,mTemp) then
      showmessage(mTemp);
    finally
      mPrivate.Free;
      mPublic.Free;
    end;
  end;
end;

I included two helper functions for turning the streams into Base64 encoded strings, simply called rsaKeyToBase64() and rsaBase64ToKey(), its is sometimes easier to transport the keys as text (and also to display the results while working).

Encrypting a stream

procedure TForm1.Button2Click(Sender: TObject);
var
  mKey: TStringStream;
  mText:  String;
  mSrc: TStringStream;
  mdst: TStringStream;
begin
  //Replace mSrc with your filestream
  mSrc:=TStringStream.Create;
  try
    mDst:=TStringStream.Create;
    try
      if TCryptoAPI.rsaBase64ToKey("Base64 key text here",TStream(mKey)) then
      begin
        try
          //Remove this obviously when encrypting a file or a memory stream
          mSrc.WriteString("Text/data to encrypt here");
          mSrc.Position:=0;

          if not TCryptoAPI.rsaCryptStream(mKey,mSrc,mDst) then
          RaiseLastOSError;
        finally
          mKey.Free;
        end;
      end;
    finally
      mDst.Free;
    end;
  finally
    mSrc.Free;
  end;
end;

To decrypt a stream, do the same as above but call TCryptoAPI.rsaDecryptStream() instead.

Voila! Next we will implement the code for encrypting passwords with the crypto-key-set!

CryptoAPI part 2 – Encrypt something

In my last post I added Hashing methods to our little unit, this time we add the ability to encrypt and decrypt streams using a segment of data as the basis for a key (this must not be confused with encrypting using a crypto-key, that is coming later).

Well, here is the unit so far – Enjoy!

  unit crypto;

  interface

  uses
  Winapi.Windows, System.SysUtils, System.Classes,
  Soap.EncdDecd,
  wcrypt2;

  type

  TCryptoAPI = Class
  protected
    class function  rsaMakeHash(const aHashType:ULONG;
          const HashBufLen:Integer;
          const aData:TStream;var aText:String):Boolean;
  public
    class function  rsaMakeKeys(var aPrivate,aPublic:TStream):Boolean;
    class function  rsaKeyToBase64(const aKey:TStream;var aText:String):Boolean;
    class function  rsaBase64ToKey(const aText:String;var aKey:TStream):Boolean;
    class function  rsaMakeSHAHash(const aData:TStream;var aText:String):Boolean;
    class function  rsaMakeMD5Hash(const aData:TStream;var aText:String):Boolean;

    class function  rsaCryptStream(const aKey:TStream;const aSourceStream:TStream;
                    const aTargetStream:TStream):Boolean;

    class function  rsaDecryptStream(Const aKey:TStream;const aSourceStream:TStream;
                    const aTargetStream:TStream):Boolean;

  End;

  implementation

  Const
  CNT_RSA_1024BIT_KEY = $04000000;
  CNT_RSA_512BIT_KEY  = $02000000;

class function TCryptoAPI.rsaMakeHash(const aHashType:ULONG;
          const HashBufLen:Integer;
          const aData:TStream;var aText:String):Boolean;
var
  mProvider: HCRYPTPROV;
  mHash:  HCRYPTHASH;
  mTotal:   Int64;
  mRead:    Int64;
  mBuffer:  PByte;
  mHashBuffer: packed array[1..512] of byte;
  mHashByteLen:  Integer;
  x:  Integer;
Begin
  setLength(aText,0);
  result:=False;

  if aData<>NIL then
  begin
    if aData.Size>0 then
    begin
      aData.Position:=0;
      if CryptAcquireContext(@mProvider, nil, nil,
      PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) then
      Begin
        try
          if CryptCreateHash(mProvider,aHashType,0,0,@mHash) then
          begin
            try
              mBuffer:=Allocmem(1024);
              try
                mTotal:=aData.Size;
                repeat
                  mRead:=aData.Read(mBuffer^,SizeOf(mBuffer));
                  if mRead>0 then
                  begin
                    if not CryptHashData(mHash,mBuffer,mRead, 0) then
                    break;
                  end;
                  mTotal:=mTotal - mRead;
                until mTotal<1;

                mHashByteLen:=HashBufLen;
                if CryptGetHashParam(mHash, HP_HASHVAL, @mHashBuffer,
                @mHashByteLen, 0) then
                Begin
                  for x:=1 to mHashByteLen do
                  aText:=aText + IntToHex(mHashBuffer[x],2);
                  result:=True;
                end;
              finally
                FreeMem(mbuffer);
              end;
            finally
              CryptDestroyHash(mHash);
            end;
          end;
        finally
          (* Release crypto provider context *)
          CryptReleaseContext(mProvider, 0);
        end;
      end;
    end;
  end;
end;

class function TCryptoAPI.rsaMakeMD5Hash(const aData: TStream;
  var aText: String): Boolean;
Begin
  result:=TCryptoAPI.rsaMakeHash(CALG_MD5,16,aData,atext);
end;

class function TCryptoAPI.rsaMakeSHAHash(const aData:TStream;
      var aText:String):Boolean;
Begin
  result:=TCryptoAPI.rsaMakeHash(CALG_SHA1,20,aData,atext);
end;

class function TCryptoAPI.rsaDecryptStream(Const aKey:TStream;
        const aSourceStream:TStream;
        const aTargetStream:TStream):Boolean;
var
  mProvider: HCRYPTPROV;
  key: HCRYPTKEY;
  mTotal:   Int64;
  mRead:    DWord;
  mBuffer:  PByte;
  mPrefetch:  Integer;
  mHash:  HCRYPTHASH;
  mHashBuffer:  PByte;
begin
  result:=False;
  if aKey<>NIL then
  begin
    if aKey.Size>0 then
    begin
      aKey.Position:=0;
      if aSourceStream<>NIl then
      begin
        if atargetStream<>NIl then
        begin
          (* Get crypto-API context *)
          if CryptAcquireContext(@mProvider, nil, nil,
          PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) then
          Begin
            try
              (* Create a Hash object *)
              if CryptCreateHash(mProvider, CALG_MD5, 0, 0, @mHash) then
              Begin

                try
                  (* Build the hash based on our key *)
                  mHashBuffer:=Allocmem(1024);
                  try
                    mTotal:=aKey.Size;
                    repeat
                      mRead:=aKey.Read(mHashBuffer^,1024);
                      if mRead>0 then
                      begin
                        if not CryptHashData(mHash,mHashBuffer,mRead,0) then
                        break;
                      end else
                      break;
                      mTotal:=mTotal - mRead;
                    until mTotal<1;

                    (* re-wind source stream *)
                    aSourceStream.Position:=0;

                    (* Derive an ecryption key from our hash *)
                    if CryptDeriveKey(mProvider, CALG_RC4, mHash, 0, @key) then
                    Begin
                      (* Query the prefetch-buffer for the context *)
                      mPrefetch:=1024;
                      if CryptEncrypt(key,0,true,0,NIL,@mPrefetch,mPrefetch) then
                      Begin
                        (* Allocate encryption cache *)
                        mBuffer:=Allocmem(mPrefetch);
                        try
                          mTotal:=aSourceStream.Size;
                          repeat
                            mRead:=aSourceStream.Read(mBuffer^,mPrefetch);
                            mTotal:=mTotal - mRead;
                            if mRead>0 then
                            begin
                              (* Encrypt read buffer *)
                              if not cryptDecrypt(key,0,
                              (mTotal<1),0,
                              mBuffer,@mRead) then
                              RaiseLastOSError;

                              (* Write encrypted buffer to target *)
                              atargetStream.Write(mBuffer^,mRead);
                            end else
                            break;
                          until mTotal<1;

                          (* Re-wind and return *)
                          aTargetStream.position:=0;
                          result:=aTargetStream.size>0;
                        finally
                          freeMem(mBuffer);
                        end;
                      end;
                    end else
                    RaiseLastOSError;
                  finally
                    FreeMem(mHashBuffer);
                  end;
                finally
                  (* Release the hash *)
                  CryptDestroyHash(mHash);
                end;
              end else
              RaiseLastOSError;
            finally
              (* Release crypto provider context *)
              CryptReleaseContext(mProvider, 0);
            end;
          end;
        end;
      end;
    end;
  end;
end;

(* NOTE: aKey here can be anything, not the same as a key-pair (!)
   What you can do is to generate a hash of a password, store that
   hash in a stream - and then use that as the key stream *)
class function TCryptoAPI.rsaCryptStream(const aKey, aSourceStream,
  aTargetStream: TStream): Boolean;
var
  mProvider: HCRYPTPROV;
  key: HCRYPTKEY;
  mTotal:   Int64;
  mRead:    DWord;
  mBuffer:  PByte;
  mPrefetch:  Integer;
  mHash:  HCRYPTHASH;
  mHashBuffer:  PByte;
begin
  result:=False;
  if aKey<>NIL then
  begin
    if aKey.Size>0 then
    begin
      aKey.Position:=0;
      if aSourceStream<>NIl then
      begin
        if atargetStream<>NIl then
        begin
          (* Get crypto-API context *)
          if CryptAcquireContext(@mProvider, nil, nil,
          PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) then
          Begin

            try
              (* Create a Hash object *)
              if CryptCreateHash(mProvider, CALG_MD5, 0, 0, @mHash) then
              Begin

                try
                  (* Build the hash based on our key *)
                  mHashBuffer:=Allocmem(1024);
                  try
                    mTotal:=aKey.Size;
                    repeat
                      mRead:=aKey.Read(mHashBuffer^,1024);
                      if mRead>0 then
                      begin
                        if not CryptHashData(mHash,mHashBuffer,mRead,0) then
                        break;
                      end else
                      break;
                      mTotal:=mTotal - mRead;
                    until mTotal<1;

                    (* re-wind source stream *)
                    aSourceStream.Position:=0;

                    (* Derive an ecryption key from our hash *)
                    if CryptDeriveKey(mProvider, CALG_RC4, mHash, 0, @key) then
                    Begin
                      (* Query the prefetch-buffer for the context *)
                      mPrefetch:=1024;
                      if CryptEncrypt(key,0,true,0,NIL,@mPrefetch,mPrefetch) then
                      Begin
                        (* Allocate encryption cache *)
                        mBuffer:=Allocmem(mPrefetch);
                        try
                          mTotal:=aSourceStream.Size;
                          repeat
                            mRead:=aSourceStream.Read(mBuffer^,mPrefetch);
                            mTotal:=mTotal - mRead;
                            if mRead>0 then
                            begin
                              (* Encrypt read buffer *)
                              if not CryptEncrypt(key,0,
                              Bool(mTotal<1),0,
                              mBuffer,@mRead,mRead) then
                              RaiseLastOSError;

                              (* Write encrypted buffer to target *)
                              atargetStream.Write(mBuffer^,mRead);
                            end else
                            break;
                          until mTotal<1;

                          (* Re-wind and return *)
                          aTargetStream.position:=0;
                          result:=aTargetStream.size>0;
                        finally
                          freeMem(mBuffer);
                        end;
                      end;
                    end else
                    RaiseLastOSError;
                  finally
                    FreeMem(mHashBuffer);
                  end;
                finally
                  (* Release the hash *)
                  CryptDestroyHash(mHash);
                end;
              end else
              RaiseLastOSError;
            finally
              (* Release crypto provider context *)
              CryptReleaseContext(mProvider, 0);
            end;
          end;
        end;
      end;
    end;
  end;
end;

class function TCryptoAPI.rsaBase64ToKey(const aText:String;
      var aKey:TStream):Boolean;
var
  mSrc: TStringStream;
  mdst: TmemoryStream;
begin
  result:=False;
  aKey:=NIL;
  if Length(aText)>0 then
  begin
    mSrc:=TStringStream.Create(aText);
    try
      mdst:=TmemoryStream.Create;
      try
        DecodeStream(mSrc,mDst);
      except
        on exception do
        mdst.Free;
      end;

      mDst.Position:=0;
      aKey:=mDSt;
      result:=True;

    finally
      mSrc.Free;
    end;
  end;
end;

class function TCryptoAPI.rsaKeyToBase64(const aKey: TStream;
  var aText: String): Boolean;
var
  mTemp:  TStringStream;
Begin
  setLength(aText,0);
  result:=False;
  if aKey<>NIL then
  begin
    mtemp:=TStringStream.Create;
    try
      aKey.Position:=0;
      encodeStream(aKey,mTemp);
      aText:=mTemp.DataString;
      result:=True;
    finally
      mtemp.Free;
    end;
  end;
end;

class function TCryptoAPI.rsaMakeKeys(var aPrivate,
  aPublic: TStream): Boolean;
var
  mProvider: HCRYPTPROV;
  mKeyPair: HCRYPTKEY;
  buflen: DWORD;
begin
  aPrivate:=NIL;
  aPublic:=NIL;
  result:=False;

  (* Get crypto-API context *)
  if CryptAcquireContext(@mProvider, nil, nil, PROV_RSA_FULL,CRYPT_VERIFYCONTEXT) then
  Begin
    try
      if CryptGenKey(mProvider, AT_KEYEXCHANGE,
      CNT_RSA_1024BIT_KEY or CRYPT_EXPORTABLE, @mKeyPair) then
      Begin
        try
          (* Query size of private buffer *)
          if CryptExportKey(mKeyPair, 0, PRIVATEKEYBLOB, 0, nil, @buflen) then
          Begin
            (* set private buffer to default size *)
            aPrivate:=TMemoryStream.Create;
            aPrivate.Size:=bufLen;

            (* export private key to buffer *)
            if CryptExportKey(mKeyPair, 0, PRIVATEKEYBLOB, 0,
            PByte(TMemoryStream(aPrivate).Memory), @buflen) then
            Begin

              (* Query size of pubic buffer *)
              if CryptExportKey(mKeyPair, 0, PUBLICKEYBLOB, 0, nil, @buflen) then
              Begin
                (* set public buffer to default size *)
                aPublic:=TMemoryStream.Create;
                aPublic.Size:=bufLen;

                (* export public key to buffer *)
                if CryptExportKey(mKeyPair, 0, PUBLICKEYBLOB, 0,
                PByte(TMemoryStream(aPublic).Memory), @buflen) then
                Begin
                  aPrivate.Position:=0;
                  aPublic.Position:=0;
                  result:=True;
                end else
                begin
                  FreeAndNIL(aPrivate);
                  FreeAndNIL(aPublic);
                  RaiseLastOSError;
                end;
              end;
            end else
            begin
              FreeAndNIL(aPrivate);
              RaiseLastOSError;
            end;
          end;
        finally
          (* Release key-pair *)
          CryptDestroyKey(mKeyPair);
        end;
      end;
    finally
      (* Release crypto provider context *)
      CryptReleaseContext(mProvider, 0);
    end;
  end;
end;

  end.

CryptoAPI and hashing

I will openly admit that I have little experience with the Microsoft Cryptography API. My previous hands-on experience with using certificates with Delphi was panic strikken to say the least. I had to support HTTPS via Indy, using OpenSSL to do the job; and I found that Delphi’s support for modern certificate standards (back then) were quite thin on the ground. Also, using openSSL to encrypt streams of data was likewise an undocumented black art. I was able to piece together a working unit from snippets I found online mixed with my own C/C++ port – but it was a terrible solution to what must be considered a modern, everyday programming task.

Anyways, I am putting together a library to solve “common use” of the Microsoft Cryptography API. A set of routines that can be dropped into a project and used to support the most widely used features. Rather than simply porting the headers (which has been done by several programmers before me) I want simplified wrapper classes that are easy to use.

My own needs included, the most common requirements asked for by Delphi developers seems to be (in no particular order):

• Generating a hash of a stream, string or memory buffer
• Creating keys on the fly
• Encrypting or decrypting a file based on a key
• Signing a file using a key
• Signing an XML document using a key
• Signing a PDF document using a key
• Signature verification

Note: The term “key” here is ambiguous, it may refer to a crypto-key or a crypto-hash. You dont encrypt using a password (old school) but rather by generating a unique hash of the password (if you are rolling your own security that is, certificates and keys have stricts guidelines for use.

My uncle’s hashed haggis

Right – on with the code! Generating a Hash from a pice of data is fairly straight forward, and it goes a little something like this:

  TCryptoAPI = Class
  protected
    class function  rsaMakeHash(const aHashType:ULONG;
          const HashBufLen:Integer;
          const aData:TStream;var aText:String):Boolean;
  public
    class function  rsaMakeSHAHash(const aData:TStream;var aText:String):Boolean;
    class function  rsaMakeMD5Hash(const aData:TStream;var aText:String):Boolean;
  End;

class function TCryptoAPI.rsaMakeHash(const aHashType:ULONG;
          const HashBufLen:Integer;
          const aData:TStream;var aText:String):Boolean;
var
  mProvider: HCRYPTPROV;
  mHash:  HCRYPTHASH;
  mTotal:   Int64;
  mRead:    Int64;
  mBuffer:  PByte;
  mHashBuffer: packed array[1..512] of byte;
  mHashByteLen:  Integer;
  x:  Integer;
Begin
  setLength(aText,0);
  result:=False;

  if aData<>NIL then
  begin
    if aData.Size>0 then
    begin
      aData.Position:=0;
      if CryptAcquireContext(@mProvider, nil, nil,
      PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) then
      Begin
        try
          if CryptCreateHash(mProvider,aHashType,0,0,@mHash) then
          begin
            try
              mBuffer:=Allocmem(1024);
              try
                mTotal:=aData.Size;
                repeat
                  mRead:=aData.Read(mBuffer^,SizeOf(mBuffer));
                  if mRead>0 then
                  begin
                    if not CryptHashData(mHash,mBuffer,mRead, 0) then
                    break;
                  end;
                  mTotal:=mTotal - mRead;
                until mTotal<1;

                mHashByteLen:=HashBufLen;
                if CryptGetHashParam(mHash, HP_HASHVAL, @mHashBuffer,
                @mHashByteLen, 0) then
                Begin
                  for x:=1 to mHashByteLen do
                  aText:=aText + IntToHex(mHashBuffer[x],2);
                  result:=True;
                end;
              finally
                FreeMem(mbuffer);
              end;
            finally
              CryptDestroyHash(mHash);
            end;
          end;
        finally
          (* Release crypto provider context *)
          CryptReleaseContext(mProvider, 0);
        end;
      end;
    end;
  end;
end;

class function TCryptoAPI.rsaMakeMD5Hash(const aData: TStream;
  var aText: String): Boolean;
Begin
  result:=TCryptoAPI.rsaMakeHash(CALG_MD5,16,aData,atext);
end;

class function TCryptoAPI.rsaMakeSHAHash(const aData:TStream;
      var aText:String):Boolean;
Begin
  result:=TCryptoAPI.rsaMakeHash(CALG_SHA1,20,aData,atext);
end;

Well, that wasnt to hard. Then of course comes the creation of keys, or a key-pair. You have one private key and one public key. That is fairly straightforward as well, although I need to get a full overview of the crypt flags (scavenger the C headers):

class function TCryptoAPI.rsaMakeKeys(var aPrivate,
  aPublic: TStream): Boolean;
const
  RSA1024BIT_KEY = $04000000;
var
  mProvider: HCRYPTPROV;
  mKeyPair: HCRYPTKEY;
  buflen: DWORD;
begin
  aPrivate:=NIL;
  aPublic:=NIL;
  result:=False;

  (* Get crypto-API context *)
  if CryptAcquireContext(@mProvider, nil, nil, PROV_RSA_FULL,CRYPT_VERIFYCONTEXT) then
  Begin
    try
      if CryptGenKey(mProvider, AT_KEYEXCHANGE,
      RSA1024BIT_KEY or CRYPT_EXPORTABLE, @mKeyPair) then
      Begin
        try
          (* Query size of private buffer *)
          if CryptExportKey(mKeyPair, 0, PRIVATEKEYBLOB, 0, nil, @buflen) then
          Begin
            (* set private buffer to default size *)
            aPrivate:=TMemoryStream.Create;
            aPrivate.Size:=bufLen;

            (* export private key to buffer *)
            if CryptExportKey(mKeyPair, 0, PRIVATEKEYBLOB, 0,
            PByte(TMemoryStream(aPrivate).Memory), @buflen) then
            Begin

              (* Query size of pubic buffer *)
              if CryptExportKey(mKeyPair, 0, PUBLICKEYBLOB, 0, nil, @buflen) then
              Begin
                (* set public buffer to default size *)
                aPublic:=TMemoryStream.Create;
                aPublic.Size:=bufLen;

                (* export public key to buffer *)
                if CryptExportKey(mKeyPair, 0, PUBLICKEYBLOB, 0,
                PByte(TMemoryStream(aPublic).Memory), @buflen) then
                Begin
                  aPrivate.Position:=0;
                  aPublic.Position:=0;
                  result:=True;
                end else
                begin
                  FreeAndNIL(aPrivate);
                  FreeAndNIL(aPublic);
                  RaiseLastOSError;
                end;
              end;
            end else
            begin
              FreeAndNIL(aPrivate);
              RaiseLastOSError;
            end;
          end;
        finally
          (* Release key-pair *)
          CryptDestroyKey(mKeyPair);
        end;
      end;
    finally
      (* Release crypto provider context *)
      CryptReleaseContext(mProvider, 0);
    end;
  end;
end;

Now the fun really begins, namely to encrypt and decrypt something (!)

To be continued shortly …

Arrrgh….

Im gonna fix this certificate thing once and for all. Porting this crap to Delphi ASAP!

// Sign
void Sign(wchar_t * SignerName, wchar_t * DataFileName, wchar_t * SignatureFileName)
{
	// Variables
	HCERTSTORE hStoreHandle = NULL;
	PCCERT_CONTEXT pSignerCert = NULL;
	HCRYPTPROV hCryptProv = NULL;
	DWORD dwKeySpec = 0;
	HCRYPTHASH hHash = NULL;
	HANDLE hDataFile = NULL; 
	BOOL bResult = FALSE;
	BYTE rgbFile[BUFSIZE];
	DWORD cbRead = 0;
	DWORD dwSigLen = 0;
	BYTE * pbSignature = NULL;
	HANDLE hSignatureFile = NULL;
	DWORD lpNumberOfBytesWritten = 0;

	wprintf(L"SIGNING\n\n");

	// Open the certificate store.
	hStoreHandle = CertOpenStore(
		CERT_STORE_PROV_SYSTEM,
		0,
		NULL,
		CERT_SYSTEM_STORE_CURRENT_USER,
		CERT_PERSONAL_STORE_NAME
	);
	CheckError((BOOL)hStoreHandle, L"CertOpenStore....................... ");

	// Get signer's certificate with access to private key.
	do {
		// Get a certificate that matches the search criteria
		pSignerCert = CertFindCertificateInStore(
			hStoreHandle,
			MY_TYPE,
			0,
			CERT_FIND_SUBJECT_STR,
			SignerName,
			pSignerCert
		);
		CheckError((BOOL)pSignerCert, L"CertFindCertificateInStore.......... ");

		// Get the CSP, and check if we can sign with the private key			
		bResult = CryptAcquireCertificatePrivateKey(
			pSignerCert,
			0,
			NULL,
			&hCryptProv,
			&dwKeySpec,
			NULL
		);
		CheckError(bResult, L"CryptAcquireCertificatePrivateKey... ");

	} while ((dwKeySpec & AT_SIGNATURE) != AT_SIGNATURE);

	// Create the hash object.
	bResult = CryptCreateHash(
		hCryptProv, 
		CALG_MD5, 
		0, 
		0, 
		&hHash
	);
	CheckError(bResult, L"CryptCreateHash..................... ");

	// Open the file with the content to be signed 
	hDataFile = CreateFileW(DataFileName,
		GENERIC_READ,
		FILE_SHARE_READ,
		NULL,
		OPEN_EXISTING,
		FILE_FLAG_SEQUENTIAL_SCAN,
		NULL
	);
	CheckError((hDataFile != INVALID_HANDLE_VALUE), L"CreateFile.......................... ");

	// Compute the cryptographic hash of the data.
	while (bResult = ReadFile(hDataFile, rgbFile, BUFSIZE, &cbRead, NULL))
	{
		if (cbRead == 0)
		{
			break;
		}
		CheckError(bResult, L"ReadFile............................ ");

		bResult = CryptHashData(
			hHash, 
			rgbFile, 
			cbRead, 
			0
		);
		CheckError(bResult, L"CryptHashData....................... ");

	}
	CheckError(bResult, L"ReadFile............................ ");

	// Sign the hash object
	dwSigLen = 0;
	bResult = CryptSignHash(
		hHash, 
		AT_SIGNATURE, 
		NULL, 
		0, 
		NULL, 
		&dwSigLen
	);
	CheckError(bResult, L"CryptSignHash....................... ");

	pbSignature = (BYTE *)malloc(dwSigLen);
	CheckError((BOOL)pbSignature, L"malloc.............................. ");

	bResult = CryptSignHash(
		hHash, 
		AT_SIGNATURE, 
		NULL, 
		0, 
		pbSignature, 
		&dwSigLen
	);
	CheckError(bResult, L"CryptSignHash....................... ");

	// Create a file to save the signature
	hSignatureFile = CreateFileW(
		SignatureFileName,
		GENERIC_WRITE,
		0,
		NULL,
		CREATE_ALWAYS,
		FILE_ATTRIBUTE_NORMAL,
		NULL
	);
	CheckError((hSignatureFile != INVALID_HANDLE_VALUE), L"CreateFile.......................... ");

	// Write the signature to the file
	bResult = WriteFile(
		hSignatureFile, 
		(LPCVOID)pbSignature, 
		dwSigLen, 
		&lpNumberOfBytesWritten, 
		NULL
	);
	CheckError(bResult, L"WriteFile........................... ");

 	// Clean up and free memory.
	free(pbSignature);

	CloseHandle(hDataFile);
	CloseHandle(hSignatureFile);

	bResult = CryptDestroyHash(hHash);
	CheckError(bResult, L"CryptDestroyHash.................... ");

	bResult = CertFreeCertificateContext(pSignerCert);
	CheckError(bResult, L"CertFreeCertificateContext.......... ");

	bResult = CertCloseStore(
		hStoreHandle, 
		CERT_CLOSE_STORE_CHECK_FLAG
	);
	CheckError(bResult, L"CertCloseStore...................... ");

} 
// End of Sign

Put a fork in it

Ok, so the basic Quartex IDE prototype is nearing completion. I am going to polish it as much as I can, but focusing more on the features you expect to be working “as in Delphi” rather than going creative and adding something new. Things like search and replace dialogs need to be fast, accurate, responsive and non-modal. Keyboard shortcuts should not collide, visual appearance should be balanced, exposed features in terms of buttons should be intuitive and not dominating;

And last but not least, I want the IDE to fast, flicker free and responsive. Large Delphi applications can sometimes become a bit sluggish, especially if the GUI deploy an abundance of nested TPanels to force the look and feel of things. So I am sticking to as little TPanels as possible, using only standard and very basic VCL components that are available on all platforms.

And if this is ever going to run under firemonkey I need to set up an enable/disable system which mimics the use of actions. I find it hard to believe that so many programmers havent used (or even heard of) actions under Delphi. It is probably the best RAD feature Delphi has to offer over database management and frames. Which is why I havent even considered using Firemonkey for any of my projects, because it feels like taking a step backwards.

Why a new IDE?

The reason the Quartex IDE is important, is because we (the Delphi community) really don’t have an “out of the box” IDE that can be bought/forked and used for new and exciting projects. There is no public research-sandbox where people can experiment with the language, try out new ideas for object pascal and break the rules (so to speak). Everyone has to roll their own with mixed results. This used to be the case for text-editors, until SynEdit came along and unified and perfected “code editing” once and for all.

So the idea is to polish and make the IDE as solid and well written as possible, making sure it remains as agnostic and oblivious to the compiler architecture as possible.

The bridge

The hard part is not “getting it to work”, but rather “getting it to work without mixing apples and pears”. I want the compiler sub-system completely separated from the generic IDE. And I want the IDE to provide its services (editing, debugging, package management etc.) without having to care about “who or what” uses them. I need symbol info, ok – here you go. I need syntax proposals, ok – here you go. If a service is registered and implements the interfaces required things should just work.

The bridge between the ide and the compiler is (as it should be), an intermediate class/interface hierarchy and information layer. So all those cool functions like the ability to display a live overview of classes and methods – should be delivered to the IDE in a uniform way. Completely decoupled from whatever compiler is being used.

The final build

Once the prototype is complete, tested and made rock-solid — I will look into getting it ported. Since there is a bug in FPC generics (which eric has reported several times) the DWScript compiler and runtime cannot be ported to freepascal, which is really sad since that would allow us to target linux, unix, osx (which is a variation of unix) and windows straight out of the box. So we are left with Firemonkey. This really is a problem because synEdit have yet to be ported to that platform, and also actions are not implemented under firemonkey (hence my question to pawel at the firemonkey presentation expo in oslo).

A firemonkey port of synEdit is really, really needed at this point (so if anyone is up for a challenge, there you have it).

Why Actions never made it into Firemonkey

A couple of years back I went to se Pawel Glowacki present Firemonkey for the Norwegian Delphi community in Oslo.

Use the force luke!

During that meetup two good questions were asked by the audience. The first question was from Halvard Vassbotn, which i seem to recall asked about threading and “what is the point of a 3d spreadsheet”, and the second question was from me – asking if fire monkey supported messages. I already suspected that Firemonkey had no fallback mechanism for messages like Kylix had, but it was a serious question since the majority of Delphi applications rely on (or use) messages as a part of their architecture.

One of the benefits of Delphi over other languages is the introduction of Actions and Action-lists. Using actions to isolate code that can be connected to menu items, buttons and options is a great time saver. And more importantly, to be able to isolate testing of action enable states (should a button be enabled right now?) is really a game changer for RAD development. But for some morbid reason this has been omitted from Firemonkey, leaving people to write “somecomponent.enabled:=true” and “somecomponent.enabled:=False” all over their code. The entire point of actions was to get rid of this old-school problem. To this day C# or Visual Basic has nothing like it – and now Delphi/Firemonkey is taking a step backwards.

Interestingly enough, Pavel changed the subject faster than a weasel  – and ridiculed the question instead. Something which surprised me a lot, since he is supposed to be a professional representative of Embarcadero. And thanks for the keychain Pavel 😉 Everyone else got a t-shirt and a mug.. And you wonder why I make compilers [sic].

Either way, the reason Actions are not supported by Firemonkey because they are based on messages. Which is silly really because a simple callback system hooking into the application idle-time could have solved it. Making Firemonkey much richer in the process.