ssl_sbb.pas

Synapse The synchronyous socket library. File content: 1.) About Synapse 2.) Distribution pa

{==============================================================================|
| Project : Ararat Synapse                                       | 001.000.001 |
|==============================================================================|
| Content: SSL support for SecureBlackBox                                     |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005.                     |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|   Allen Drennan ([e-mail])                                      |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{:@abstract(SSL plugin for Eldos SecureBlackBox)

For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
of keys and certificates refer to SecureBlackBox documentation.
}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$H+}

unit ssl_sbb;

interface

uses
  SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode,
  SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage,
  SBUtils, SBConstants, SBSessionPool;

const
  DEFAULT_RECV_BUFFER=32768;  

type
  {:@abstract(class implementing SecureBlackbox SSL plugin.)
   Instance of this class will be created for each @link(TTCPBlockSocket).
   You not need to create instance of this class, all is done by Synapse itself!}
  TSSLSBB=class(TCustomSSL)
  protected
    FServer: Boolean;
    FElSecureClient:TElSecureClient;
    FElSecureServer:TElSecureServer;
    FElCertStorage:TElMemoryCertStorage;
    FElX509Certificate:TElX509Certificate;
  private
    FRecvBuffer:String;
    FRecvBuffers:String;
    FRecvDecodedBuffers:String;
    function Init(Server:Boolean):Boolean;
    function DeInit:Boolean;
    function Prepare(Server:Boolean):Boolean;
    procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);
    procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);
    procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;out Written:LongInt);
    procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);
  public
    constructor Create(const Value: TTCPBlockSocket); override;
    destructor Destroy; override;
    {:See @inherited}
    function LibVersion: String; override;
    {:See @inherited}
    function LibName: String; override;
    {:See @inherited and @link(ssl_sbb) for more details.}
    function Connect: boolean; override;
    {:See @inherited and @link(ssl_sbb) for more details.}
    function Accept: boolean; override;
    {:See @inherited}
    function Shutdown: boolean; override;
    {:See @inherited}
    function BiShutdown: boolean; override;
    {:See @inherited}
    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
    {:See @inherited}
    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
    {:See @inherited}
    function WaitingData: Integer; override;
    {:See @inherited}
    function GetSSLVersion: string; override;
    {:See @inherited}
    function GetPeerSubject: string; override;
    {:See @inherited}
    function GetPeerIssuer: string; override;
    {:See @inherited}
    function GetPeerName: string; override;
    {:See @inherited}
    function GetPeerFingerprint: string; override;
    {:See @inherited}
    function GetCertInfo: string; override;
  published
    property ELSecureClient:TElSecureClient read FElSecureClient write FElSecureClient;
    property ELSecureServer:TElSecureServer read FElSecureServer write FElSecureServer;
  end;

implementation

// on error
procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);

begin
  FLastErrorDesc:='';
  FLastError:=ErrorCode;
end;

// on send
procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);

var
  lResult:Integer;

begin
  lResult:=Send(FSocket.Socket,Buffer,Size,0);
  if lResult=SOCKET_ERROR then
    begin
      FLastErrorDesc:='';
      FLastError:=WSAGetLastError;
    end;
end;

// on receive
procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;out Written:LongInt);

begin
  if Length(FRecvBuffers)<=MaxSize then
    begin
      Written:=Length(FRecvBuffers);
      Move(FRecvBuffers[1],Buffer^,Written);
      FRecvBuffers:='';
    end
  else
    begin
      Written:=MaxSize;
      Move(FRecvBuffers[1],Buffer^,Written);
      Delete(FRecvBuffers,1,Written);
    end;
end;

// on data
procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);

var
  lString:String;

begin
  SetLength(lString,Size);
  Move(Buffer^,lString[1],Size);
  FRecvDecodedBuffers:=FRecvDecodedBuffers+lString;
end;

{ inherited }

constructor TSSLSBB.Create(const Value: TTCPBlockSocket);

begin
  inherited Create(Value);
  FServer:=FALSE;
  FElSecureClient:=NIL;
  FElSecureServer:=NIL;
  FElCertStorage:=NIL;
  FElX509Certificate:=NIL;
  SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER);
  FRecvBuffers:='';
  FRecvDecodedBuffers:='';
end;

destructor TSSLSBB.Destroy;

begin
  DeInit;
  inherited Destroy;
end;

function TSSLSBB.LibVersion: String;

begin
  Result:='SecureBlackBox';
end;

function TSSLSBB.LibName: String;

begin
  Result:='ssl_sbb';
end;

function FileToString(lFile:String):String;

var
  lStream:TMemoryStream;

begin
  Result:='';
  lStream:=TMemoryStream.Create;
  if lStream<>NIL then
    begin
      lStream.LoadFromFile(lFile);
      if lStream.Size>0 then
        begin
          lStream.Position:=0;
          SetLength(Result,lStream.Size);
          Move(lStream.Memory^,Result[1],lStream.Size);
        end;
      lStream.Free;
    end;
end;

function TSSLSBB.Init(Server:Boolean):Boolean;

var
  loop1:Integer;
  lStream:TMemoryStream;
  lCertificate,lPrivateKey:String;

begin
  Result:=FALSE;
  FServer:=Server;

  // init, certificate
  if FCertificateFile<>'' then
    lCertificate:=FileToString(FCertificateFile)
  else
    lCertificate:=FCertificate;
  if FPrivateKeyFile<>'' then
    lPrivateKey:=FileToString(FPrivateKeyFile)
  else
    lPrivateKey:=FPrivateKey;
  if (lCertificate<>'') and (lPrivateKey<>'') then
    begin
      FElX509Certificate:=TElX509Certificate.Create(NIL);
      if FElX509Certificate<>NIL then
        begin
          with FElX509Certificate do
            begin
              lStream:=TMemoryStream.Create;
              try
                WriteStrToStream(lStream,lCertificate);
                lStream.Seek(0,soFromBeginning);
                LoadFromStream(lStream);
              finally
                lStream.Free;
              end;
              lStream:=TMemoryStream.Create;
              try
                WriteStrToStream(lStream,lPrivateKey);
                lStream.Seek(0,soFromBeginning);
                LoadKeyFromStream(lStream);
              finally
                lStream.Free;
              end;
              FElCertStorage:=TElMemoryCertStorage.Create(NIL);
              if FElCertStorage<>NIL then
                begin
                  FElCertStorage.Clear;
                  FElCertStorage.Add(FElX509Certificate);
                end;
            end;
        end;
    end;

  // init, as server