{-------------------------------------------------------------------------------
Author :      Jan Tomasek
Description :
EMail :       xtomasej@fel.cvut.cz       http://www.feld.cvut.cz/~xtomasej
Creation :    Jul 1998
Version :     0.20
Support :
Legal issues:
      Copyright (C) 1998 by Jan Tomasek <xtomasej@fel.cvut.cz>
      All rights reserved.

      This library is free for commercial and non-commercial use as long as
      the following conditions are aheared to.  The following conditions
      apply to all code found in this distribution, except Eric Young
      header files in ./headers folder.  The documentation included with this
      distribution is covered by the same copyright terms.

      Copyright remains Jan Tomasek's, and as such any Copyright notices in
      the code are not to be removed.
      If this package is used in a product, Jan Tomasek should be given
      attribution as the author of the parts of the library used.
      This can be in the form of a textual message at program startup or
      in documentation (online or textual) provided with the package.

      Redistribution and use in source and binary forms, with or without
      modification, are permitted provided that the following conditions
      are met:
      1. Redistributions of source code must retain the copyright
         notice, this list of conditions and the following disclaimer.
      2. 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.
      3. All advertising materials mentioning features or use of this software
         must display the following acknowledgement:
             "This product includes software written by
              Jan Tomasek <xtomasej@fel.cvut.cz>"

      THIS SOFTWARE IS PROVIDED BY JAN TOMASEK ``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 AUTHOR 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 licence and distribution terms for any publically available version or
      derivative of this code cannot be changed.  i.e. this code cannot simply be
      copied and put under another distribution licence
      [including the GNU Public Licence.]

History :
  21.07.98 Released for testing
  24.07.98 First usefull version
    .07.98 All transated parts is in ssl.h marked  with '...'. Sometimes I had
           to change order of types and constants, pascal isn't c.
           Added prop. OnSSLSessionConnected, OnSSLSessionAccepted and SSLState.
           Added function SSLcallback ... global in this unit.
-------------------------------------------------------------------------------}

Unit SSLWSock;

interface
Uses
  Classes, WSocket,  SSLeay,   WinProcs,
  WinSock, Messages, SysUtils, LIBeay;

Function Init:Boolean;
Procedure Done;

Type
  {$IFNDEF WIN32}
  ShortString= String;
  {$ENDIF}

  ESSLSocketException = class(Exception);

  TSSLSocketState = (sslInvalidState,
                     sslConnecting, sslConnected,
                     sslAccepting,  sslAccepted,
                     sslClosed);
  TSSLVersion= (SSLv2, SSLv3, SSLv23);

  TSSLContext= class(TPersistent)
    private
      FSSLVersion             : TSSLVersion;
      FSSLctx                 : PSSL_CTX;
      FOnError                : TNotifyEvent;

      procedure   TriggerError; virtual;
    public
      Constructor Create(Version:TSSLVersion); virtual;
      Destructor  Destroy; override;

      Procedure LoadCertificate(fName: String);

      property Context: PSSL_CTX read FSSLctx;
      property Version: TSSLVersion read FSSLVersion;
  End;

  TSSLSocket = class(TWSocket)
    private
      FSSLcon                 : PSSL;
      FSSLState               : TSSLSocketState;
      FVerifyDepth            : int;
      FVerifyError            : int;

      FAutoSSL                : Boolean;       {look at TriggerSessionConnected}
      FOnSSLSessionConnected  : TSessionConnected;
      FOnSSLSessionAccepted   : TSessionConnected;
    protected
      function    TriggerDataAvailable(Error: Word): Boolean; override;
      procedure   TriggerSessionConnected(Error : Word); override;
      procedure   TriggerSSLSessionConnected(Error : Word); virtual;
      procedure   TriggerSSLSessionAccepted(Error : Word); virtual;

      function    RealSend(Data: Pointer; Len: Integer):Integer; override;

      function    RCipherName:String;
      function    RCipherBits:Integer;
      function    RCipherVersion:String;
    public
      constructor Create(aOwner: TComponent); override;
      destructor  Destroy; override;
      procedure   InternalClose(bShut : Boolean; Error : Word); override;

      procedure   ConnectSSL; virtual;
      procedure   AcceptSSL; virtual;

      procedure   LoadCertificate(Const fName:String);
      function    Receive(Buffer: Pointer; BufferSize: integer): integer; override;
      function    ReceiveStr: string; override;

      property    SSLcon: PSSL read FSSLcon write FSSLcon;
      property    CipherBits: integer read RCipherBits;
      property    CipherName: string read RCipherName;
      property    CipherVersion: string read RCipherVersion;
    published
      property    SSLState: TSSLSocketState read FSSLState;
      property    AutoSSL:Boolean read FAutoSSL write FAutoSSL;

      property    OnSSLSessionConnected: TSessionConnected read FOnSSLSessionConnected write FOnSSLSessionConnected;
      property    OnSSLSessionAccepted : TSessionConnected read FOnSSLSessionAccepted  write FOnSSLSessionAccepted ;
  End;

Const
  WM_SSL_BASE      = (WM_USER+25000);
  WM_SSL_CONNECTING= (WM_SSL_BASE+1);
  WM_SSL_CONNECTED = (WM_SSL_BASE+2);
  WM_SSL_ACCEPTING = (WM_SSL_BASE+3);
  WM_SSL_ACCEPTED  = (WM_SSL_BASE+4);

Var
  SSLContext : TSSLContext;

Procedure Register;

implementation
Uses
  C3216, STConfig, kUnits;

Var
  Initialized : Boolean;

Procedure Register;
Begin
  RegisterComponents('Semik', [TSSLSocket]);
End;

{******************************************************************************}
{**                                                                          **}
{**                          GLOBAL FUNCTIONS                                **}
{**                                                                          **}
{******************************************************************************}
Function Init:Boolean;
Begin
  If Initialized Then Begin Result:=True; Exit; End;

  Result      := SSLeay.Init;  {Load SSLeay??.dll and LIBeay??.dll}
  Initialized := Result;
  If (not Result)or(Assigned(SSLContext)) Then Exit;

  SSLContext  := TSSLContext.Create(SSLv2);
End;

Procedure Done;
Begin
  If not Initialized Then Exit;
  Initialized:=False;

  SSLContext.Free; SSLContext:=nil;
End;

Function  AlogicAND(i:longint; mask:longint):Boolean;
Begin
  Result := (i and mask)=mask;
End;{-- AlogicAND -------------------------------------------------------------}

{$IFDEF WIN32}
{ To debug event driven programs, it is often handy to just use writeln to  }
{ write debug messages to the console. To get a console, just ask the       }
{ linker to build a console mode application. Then you'll get the default   }
{ console. The function below will make it the size you like...             }
procedure BigConsole(nCols, nLines : Integer);
var
    sc : TCoord;
    N  : DWord;
begin
    if not IsConsole then Exit;
    sc.x := nCols;
    sc.y := nLines;
    SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), sc);
    SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
                            BACKGROUND_BLUE or BACKGROUND_GREEN or
                            BACKGROUND_RED);
    sc.x := 0;
    sc.y := 0;
    FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
                               BACKGROUND_BLUE or BACKGROUND_GREEN or
                               BACKGROUND_RED,
                               nCols * nLines, sc, N);
end;{-- BigConsole ------------------------------------------------------------}
{$ENDIF}

{$F+}
Procedure SSLcallback(ssl: PSSL; location: int; ret: int); cdecl;
Var
  SSLSock  : TSSLSocket;
  OldState : TSSLSocketState;
Begin
  {Hmm... I need ignore if ret is less zero !!!Sova
     Location: 4097, ret: 1   ... this is ok starting connect loop
     Location: 4098, ret: -1  ... stuff
     Location: 4097, ret: 1   .
     Location: 4098, ret: -1  .
     Location: 4097, ret: 1   .
     Location: 4098, ret: -1  .
     Location: 4097, ret: 1   .
     Location: 4098, ret: 1   ... this is ok finished  connect loop}
  {$IFDEF DEBUG}
  WriteLn(Format('SSLcallback. Location: %d,'#9'ret: %d', [location, ret]));
  {$ENDIF}
  If ret<=0 Then Exit;

  SSLSock  := TSSLSocket(SSL_get_app_data(ssl));

  OldState := SSLSock.FSSLState;
  If AlogicAND(location, SSL_CB_CONNECT_LOOP)Then SSLSock.FSSLState:=sslConnecting;
  If AlogicAND(location, SSL_CB_CONNECT_EXIT)Then SSLSock.FSSLState:=sslConnected;
  If AlogicAND(location, SSL_CB_ACCEPT_LOOP) Then SSLSock.FSSLState:=sslAccepting;
  If AlogicAND(location, SSL_CB_ACCEPT_EXIT) Then SSLSock.FSSLState:=sslAccepted;

  If OldState<>SSLSock.FSSLState Then Begin
    Case SSLSock.FSSLState of
      sslConnecting : ;
      sslConnected  : Begin
        SSLSock.TriggerSSLSessionConnected(0);
        SSLSock.TriggerDataSent(0);
      End;
      sslAccepting  : ;
      sslAccepted   : Begin
        SSLSock.TriggerSSLSessionAccepted(0);
        SSLSock.TriggerDataSent(0);
      End;
    End;
  End;
End;

{ should be X509 * but we can just have them as char *. }
{ this function is based on same name func from aps/s_cb.c}

function verify_callback(ok:int; ctx:PX509_STORE_CTX):int; cdecl;
Var
  buf      : Array [0..256-1] of char;
  err_cert : PX509;
  err,depth: int;
Const
  verify_depth : int =0;
  verify_error : int =X509_V_OK;

Begin
  err_cert := X509_STORE_CTX_get_current_cert(ctx);
  err      := X509_STORE_CTX_get_error(ctx);
  depth    := X509_STORE_CTX_get_error_depth(ctx);

  X509_NAME_oneline(X509_get_subject_name(err_cert),buf,sizeof(buf));
  WriteLn(Format('depth=%d %s', [depth, strPas(buf)]));

  if ok<=0 Then Begin
    WriteLn(Format('verify error:num=%d:%s', [err, X509_verify_cert_error_string(err)]));
    if (verify_depth >= depth) Then Begin
      ok:=1;
      verify_error:=X509_V_OK;
    End Else Begin
      ok:=0;
      verify_error:=X509_V_ERR_CERT_CHAIN_TOO_LONG;
    End;
  End;
  Case ctx^.error of
    X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT: Begin
      X509_NAME_oneline(X509_get_issuer_name(ctx^.current_cert),buf,sizeof(buf));
      WriteLn(Format('issuer= %s', [strPas(buf)]));
    End;
    X509_V_ERR_CERT_NOT_YET_VALID,
    X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD: Begin
{      WriteLn(Format('BIO_printf(bio_err,"notBefore=");
              ASN1_UTCTIME_print(bio_err,X509_get_notBefore(ctx->current_cert));
              BIO_printf(bio_err,"\n");
              break;}
    End;
    X509_V_ERR_CERT_HAS_EXPIRED,
    X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD: Begin
{              BIO_printf(bio_err,"notAfter=");
              ASN1_UTCTIME_print(bio_err,X509_get_notAfter(ctx->current_cert));
              BIO_printf(bio_err,"\n");
              break;}
    End;
  End;
  WriteLn(Format('verify return:%d', [ok]));
  Result:=ok;
End;
{$F-}



{******************************************************************************}
{**                                                                          **}
{**                        TSSLCONTEXT METHODS                               **}
{**                                                                          **}
{******************************************************************************}

Constructor TSSLContext.Create(Version:TSSLVersion);
Begin
  FSSLVersion := Version;
  Case FSSLVersion of
    SSLv2  :FSSLctx := SSL_CTX_new(SSLv2_method);
    SSLv3  :FSSLctx := SSL_CTX_new(SSLv3_method);
    SSLv23 :FSSLctx := SSL_CTX_new(SSLv23_method);
    else    FSSLctx := SSL_CTX_new(SSLv2_method);
  End;

  SSL_CTX_set_info_callback(FSSLctx, SSLcallback);
End;

Destructor TSSLContext.Destroy;
Begin
  SSL_CTX_free(FSSLctx);
End;

Procedure TSSLContext.LoadCertificate(fName: String);
Var
  I : Integer;
Begin
  fName := fName+#0;
  I := SSL_CTX_use_certificate_file(FSSLctx, @fName[1], SSL_FILETYPE_PEM);
  I := SSL_CTX_use_PrivateKey_file (FSSLctx, @fName[1], SSL_FILETYPE_PEM);
End;

procedure   TSSLContext.TriggerError;
Begin
  if Assigned(FOnError) then FOnError(Self);
End;



{******************************************************************************}
{**                                                                          **}
{**                         TSSLSOCKET METHODS                               **}
{**                                                                          **}
{******************************************************************************}

{Std socket is reciving crypted data is posible that this data is
 for ssl library, but not user of TSSLSocket. I must check if
 in ssl buffer realy some data}
function  TSSLSocket.TriggerDataAvailable(Error: Word): Boolean;
Var
  S        : ShortString;
Begin
  { Do not allow FD_READ messages }
  WSAASyncSelect(HSocket, Handle, WM_ASYNCSELECT,
                                  FD_WRITE or FD_CLOSE or FD_CONNECT);
  try
    Result := Assigned(FOnDataAvailable);
    FRcvdFlag := True;
    if Result then while FRcvdFlag do begin
      { SSL work around }
      If FSSLState in [sslInvalidState, sslClosed] Then FRcvdFlag:=True
      Else
        If SSL_peek(FSSLcon, @S[1], 1)>0 Then
          FRcvdFlag:=True
        Else Begin{Hmmm, some ssl status data}
          Result:=True;
          FRcvdFlag:=False;
        End;

      { call handler}
      If FRcvdFlag Then FOnDataAvailable(Self, Error);

      { Hanlder may change remove event handler ! }
      Result := Assigned(FOnDataAvailable);
      if not result then Begin Break; End; 
    end;
  finally
    WSAASyncSelect(HSocket, Handle, WM_ASYNCSELECT,
                                    FD_READ or FD_WRITE or
                                    FD_CLOSE or FD_CONNECT);
  End;
End;{-- TriggerDataAvailable --------------------------------------------------}
{If is set AutoSSL property method ConnectSSL will be automaticaly called
 this is usefull in some cases but in some not. For example in telnet
 protocol is basic negotiation running trought uncrypted line}
procedure TSSLSocket.TriggerSessionConnected(Error : Word);
Begin
  Inherited TriggerSessionConnected(Error);
  WriteToLog(DebugDetailed, kuSSLWSock, 'TriggerSessionConnected', 'X');
  If Self.State=wsConnected Then
    If FAutoSSL Then ConnectSSL;
End;{-- TriggerSessionConnected -----------------------------------------------}
procedure   TSSLSocket.TriggerSSLSessionConnected(Error : Word);
Begin
  If Assigned(FOnSSLSessionConnected) Then FOnSSLSessionConnected(self, Error);
End;{-- TriggerSSLSessionConnected --------------------------------------------}
procedure   TSSLSocket.TriggerSSLSessionAccepted(Error : Word);
Begin
  If Assigned(FOnSSLSessionAccepted) Then FOnSSLSessionAccepted(self, Error);
End;{-- TriggerSSLSessionAccepted ---------------------------------------------}

Function    TSSLSocket.RealSend(Data: Pointer; Len: Integer):Integer;
Begin
  If FSSLState in [sslInvalidState, sslClosed] Then Begin
    Result:=inherited RealSend(Data, Len)
  End Else
    Result:=SSL_write(FSSLcon, Data, Len);
End;

function    TSSLSocket.RCipherName:String;
Begin
  If FSSLState in [sslInvalidState, sslClosed] Then
    Result:=''
  Else
    Result:=StrPas(SSL_CIPHER_get_name(SSL_get_current_cipher(FSSLcon)));
End;

function    TSSLSocket.RCipherBits:Integer;
Const
  nb : Integer = 0;
Begin
  If FSSLState in [sslInvalidState, sslClosed] Then
    Result:=-1
  Else
    Result:=SSL_CIPHER_get_bits(SSL_get_current_cipher(FSSLcon), nb);
End;


function    TSSLSocket.RCipherVersion:String;
Begin
  If FSSLState in [sslInvalidState, sslClosed] Then
    Result:=''
  Else
    Result:=StrPas(SSL_CIPHER_get_version(SSL_get_current_cipher(FSSLcon)));
End;


Constructor TSSLSocket.Create(aOwner: TComponent);
Begin
  Inherited Create(aOwner);

  FSSLcon      := nil;
  FSSLState    := sslClosed;
  FVerifyDepth := 0;
  FVerifyError := X509_V_OK;
  FAutoSSL     := False;
End;{-- Create ----------------------------------------------------------------}
Destructor  TSSLSocket.Destroy;
Begin
  If FSSLcon<>nil Then SSL_free(FSSLcon);

  Inherited Destroy;
End;{-- Destroy ---------------------------------------------------------------}
procedure   TSSLSocket.InternalClose(bShut : Boolean; Error : Word);
Begin
  Inherited InternalClose(bShut, Error);
  FSSLState:=sslClosed;
  If FSSLcon<>nil Then Begin
    SSL_set_shutdown(FSSLcon, SSL_SENT_SHUTDOWN);
    SSL_shutdown(FSSLcon);
  End;
End;


Procedure   TSSLSocket.ConnectSSL;
Var
  I : Integer;
Begin
  If FSSLcon<>nil Then SSL_free(FSSLcon);
  FSSLcon := SSL_new(SSLContext.Context);   {Create new SSL connection (data)}

  I := SSL_set_fd(FSSLcon,HSocket);         {Set association betwen SSL and Socket}
  SSL_set_app_data(FSSLcon, PChar(self));   {Set pointer to self for SSLcallback}
  SSL_set_connect_state     (FSSLcon);           {This socket is client}
  SSL_set_read_ahead(FSSLcon, 1);

  SSL_connect(FSSLcon);                     {Do connect!}
End;{-- ConnectSSL ------------------------------------------------------------}
Procedure TSSLSocket.AcceptSSL;
Var
  I : Integer;
Begin
  FSSLcon := SSL_new(SSLContext.Context);

  I := SSL_set_fd(FSSLcon, HSocket);
  SSL_set_app_data(FSSLcon, PChar(self));
  SSL_set_accept_state(FSSLcon);

  SSL_accept(FSSLcon);
End;{-- AcceptSSL -------------------------------------------------------------}

Procedure   TSSLSocket.LoadCertificate(Const fName:String);
Begin
  SSLContext.LoadCertificate(fName);
End;{-- LoadCertificate -------------------------------------------------------}

Function    TSSLSocket.Receive(Buffer: Pointer; BufferSize: integer): integer;
Begin
  If FSSLState in [sslInvalidState, sslClosed] Then Begin
    Result := inherited Receive(Buffer, BufferSize);
  End Else
    Result := SSL_read(FSSLcon, Buffer, BufferSize);
End;

Function    TSSLSocket.ReceiveStr: string;
Var
    lCount : LongInt;
Begin
    SetLength(Result, 0);
    lCount:=SSL_pending(FSSLcon);

{$IFDEF VER80}
    { Delphi 1 strings are limited }
    if lCount > High(Result) then
        lCount := High(Result);
{$ENDIF}
    if lCount > 0 then begin
        SetLength(Result, lCount);
        lCount := Receive(@Result[1], lCount);
        if lCount > 0 then
            SetLength(Result, lCount)
        else
            SetLength(Result, 0);
    end;
end;

initialization
  {$IFDEF DEBUG}BigConsole(80, 50);{$ENDIF}
  Initialized := False;
  SSLContext  := nil;
{$IFDEF WIN32}
finalization
  If Initialized Then Done;
{$ENDIF}
end.
