Release 27

git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@57 7c85be65-684b-0410-a082-b2ed4fbef004

SynaSSL.pas

@@ -0,0 +1,199 @@
+{==============================================================================|
+| Project : Delphree - Synapse                                   | 001.001.001 |
+|==============================================================================|
+| Content: SSL support                                                         |
+|==============================================================================|
+| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
+| (the "License"); you may not use this file except in compliance with the     |
+| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
+|                                                                              |
+| Software distributed under the License is distributed on an "AS IS" basis,   |
+| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
+| the specific language governing rights and limitations under the License.    |
+|==============================================================================|
+| The Original Code is Synapse Delphi Library.                                 |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2002.                     |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+unit SynaSSL;
+
+interface
+
+uses
+{$IFDEF LINUX}
+  Libc, SysUtils;
+{$ELSE}
+  Windows;
+{$ENDIF}
+
+const
+{$IFDEF LINUX}
+  DLLSSLName = 'libssl.so';
+  DLLUtilName = 'libcrypto.so';
+{$ELSE}
+  DLLSSLName = 'ssleay32.dll';
+  DLLUtilName = 'libeay32.dll';
+{$ENDIF}
+
+type
+  PSSL_CTX = Pointer;
+  PSSL = Pointer;
+  PSSL_METHOD = Pointer;
+  PX509 = Pointer;
+  PX509_NAME = Pointer;
+  PEVP_MD	= Pointer;
+  PInteger = ^Integer;
+
+const
+  EVP_MAX_MD_SIZE = 16+20;
+  SSL_ERROR_WANT_READ = 2;
+  SSL_ERROR_WANT_WRITE = 3;
+  SSL_ERROR_ZERO_RETURN = 6;
+
+var
+  SSLLibHandle: Integer = 0;
+  SSLUtilHandle: Integer = 0;
+
+// ssleay.dll
+  SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil;
+  SslLibraryInit : function:Integer cdecl = nil;
+  SslLoadErrorStrings : procedure cdecl = nil;
+  SslCtxSetCipherList : function(arg0: PSSL_CTX; str: PChar):Integer cdecl = nil;
+  SslCtxNew : function(meth: PSSL_METHOD):PSSL_CTX cdecl = nil;
+  SslCtxFree : procedure(arg0: PSSL_CTX) cdecl = nil;
+  SslSetFd : function(s: PSSL; fd: Integer):Integer cdecl = nil;
+  SslMethodV23 : function:PSSL_METHOD cdecl = nil;
+  SslCtxUsePrivateKeyFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil;
+  SslCtxUseCertificateFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil;
+  SslNew : function(ctx: PSSL_CTX):PSSL cdecl = nil;
+  SslFree : procedure(ssl: PSSL) cdecl = nil;
+  SslAccept : function(ssl: PSSL):Integer cdecl = nil;
+  SslConnect : function(ssl: PSSL):Integer cdecl = nil;
+  SslShutdown : function(ssl: PSSL):Integer cdecl = nil;
+  SslRead : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil;
+  SslPeek : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil;
+  SslWrite : function(ssl: PSSL; const buf: PChar; num: Integer):Integer cdecl = nil;
+  SslGetVersion : function(ssl: PSSL):PChar cdecl = nil;
+  SslGetPeerCertificate : function(ssl: PSSL):PX509 cdecl = nil;
+
+// libeay.dll
+  SslX509Free : procedure(x: PX509) cdecl = nil;
+  SslX509NameOneline : function(a: PX509_NAME; buf: PChar; size: Integer):PChar cdecl = nil;
+  SslX509GetSubjectName : function(a: PX509):PX509_NAME cdecl = nil;
+  SslX509GetIssuerName : function(a: PX509):PX509_NAME cdecl = nil;
+  SslX509NameHash : function(x: PX509_NAME):Cardinal cdecl = nil;
+  SslX509Digest : function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer cdecl = nil;
+  SslEvpMd5 : function:PEVP_MD cdecl = nil;
+
+function InitSSLInterface: Boolean;
+function DestroySSLInterface: Boolean;
+
+implementation
+
+uses SyncObjs;
+
+var
+  SSLCS: TCriticalSection;
+  SSLCount: Integer = 0;
+
+function InitSSLInterface: Boolean;
+begin
+  Result := False;
+  SSLCS.Enter;
+  try
+    if SSLCount = 0 then
+    begin
+{$IFDEF LINUX}
+      SSLLibHandle := HMODULE(dlopen(DLLSSLName, RTLD_GLOBAL));
+      SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL));
+{$ELSE}
+      SSLLibHandle := LoadLibrary(PChar(DLLSSLName));
+      SSLUtilHandle := LoadLibrary(PChar(DLLUtilName));
+{$ENDIF}
+      if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
+      begin
+        SslGetError := GetProcAddress(SSLLibHandle, PChar('SSL_get_error'));
+        SslLibraryInit := GetProcAddress(SSLLibHandle, PChar('SSL_library_init'));
+        SslLoadErrorStrings := GetProcAddress(SSLLibHandle, PChar('SSL_load_error_strings'));
+        SslCtxSetCipherList := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_cipher_list'));
+        SslCtxNew := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_new'));
+        SslCtxFree := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_free'));
+        SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd'));
+        SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method'));
+        SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_file'));
+        SslCtxUseCertificateFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_certificate_file'));
+        SslNew := GetProcAddress(SSLLibHandle, PChar('SSL_new'));
+        SslFree := GetProcAddress(SSLLibHandle, PChar('SSL_free'));
+        SslAccept := GetProcAddress(SSLLibHandle, PChar('SSL_accept'));
+        SslConnect := GetProcAddress(SSLLibHandle, PChar('SSL_connect'));
+        SslShutdown := GetProcAddress(SSLLibHandle, PChar('SSL_shutdown'));
+        SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read'));
+        SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek'));
+        SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write'));
+        SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate'));
+        SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version'));
+
+        SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free'));
+        SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline'));
+        SslX509GetSubjectName := GetProcAddress(SSLUtilHandle, PChar('X509_get_subject_name'));
+        SslX509GetIssuerName := GetProcAddress(SSLUtilHandle, PChar('X509_get_issuer_name'));
+        SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash'));
+        SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest'));
+        SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5'));
+
+        Result := True;
+      end;
+    end
+    else Result := True;
+    if Result then
+      Inc(SSLCount);
+  finally
+    SSLCS.Leave;
+  end;
+end;
+
+function DestroySSLInterface: Boolean;
+begin
+  SSLCS.Enter;
+  try
+    Dec(SSLCount);
+    if SSLCount < 0 then
+      SSLCount := 0;
+    if SSLCount = 0 then
+    begin
+      if SSLLibHandle <> 0 then
+      begin
+        FreeLibrary(SSLLibHandle);
+        SSLLibHandle := 0;
+      end;
+      if SSLUtilHandle <> 0 then
+      begin
+        FreeLibrary(SSLUtilHandle);
+        SSLLibHandle := 0;
+      end;
+    end;
+  finally
+    SSLCS.Leave;
+  end;
+  Result := True;
+end;
+
+initialization
+begin
+  SSLCS:= TCriticalSection.Create;
+end;
+
+finalization
+begin
+  SSLCS.Free;
+end;
+
+end.

blcksock.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 004.004.000 |
+| Project : Delphree - Synapse                                   | 005.002.000 |
 |==============================================================================|
 | Content: Library base                                                        |
 |==============================================================================|
@@ -37,7 +37,7 @@ uses
 {$ELSE}
   Windows, WinSock,
 {$ENDIF}
-  synsock, SynaUtil;
+  synsock, SynaUtil, SynaCode, SynaSSL;
 
 const
   cLocalhost = 'localhost';
@@ -115,6 +115,7 @@ type
     function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual;
     function PeekByte(Timeout: Integer): Byte; virtual;
     function WaitingData: Integer;
+    function WaitingDataEx: Integer;
     procedure SetLinger(Enable: Boolean; Linger: Integer);
     procedure GetSins;
     function SockCheck(SockResult: Integer): Integer;
@@ -129,6 +130,7 @@ type
     function GetLocalSinPort: Integer; virtual;
     function GetRemoteSinPort: Integer; virtual;
     function CanRead(Timeout: Integer): Boolean;
+    function CanReadEx(Timeout: Integer): Boolean;
     function CanWrite(Timeout: Integer): Boolean;
     function SendBufferTo(Buffer: Pointer; Length: Integer): Integer; virtual;
     function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; virtual;
@@ -175,6 +177,7 @@ type
     FSocksLocalPort: string;
     FSocksRemoteIP: string;
     FSocksRemotePort: string;
+    FBypassFlag: Boolean;
     function SocksCode(IP, Port: string): string;
     function SocksDecode(Value: string): integer;
   public
@@ -193,16 +196,52 @@ type
   end;
 
   TTCPBlockSocket = class(TSocksBlockSocket)
+  protected
+    FSslEnabled: Boolean;
+    FSslBypass: Boolean;
+    FSsl: PSSL;
+    Fctx: PSSL_CTX;
+    FHTTPTunnelIP: string;
+    FHTTPTunnelPort: string;
+    FHTTPTunnel: Boolean;
+    FHTTPTunnelRemoteIP: string;
+    FHTTPTunnelRemotePort: string;
+    FHTTPTunnelUser: string;
+    FHTTPTunnelPass: string;
+    procedure SetSslEnabled(Value: Boolean);
+    procedure SocksDoConnect(IP, Port: string);
+    procedure HTTPTunnelDoConnect(IP, Port: string);
   public
+    constructor Create;
+    destructor Destroy; override;
     procedure CreateSocket; override;
     procedure CloseSocket; override;
     procedure Listen;
     function Accept: TSocket;
     procedure Connect(IP, Port: string); override;
+    procedure SSLDoConnect;
+    procedure SSLDoShutdown;
+    function SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean;
     function GetLocalSinIP: string; override;
     function GetRemoteSinIP: string; override;
     function GetLocalSinPort: Integer; override;
     function GetRemoteSinPort: Integer; override;
+    function SendBuffer(Buffer: Pointer; Length: Integer): Integer; override;
+    function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; override;
+    function SSLGetSSLVersion: string;
+    function SSLGetPeerSubject: string;
+    function SSLGetPeerIssuer: string;
+    function SSLGetPeerSubjectHash: Cardinal;
+    function SSLGetPeerIssuerHash: Cardinal;
+    function SSLGetPeerFingerprint: string;
+  published
+    property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled;
+    property SSLBypass: Boolean read FSslBypass write FSslBypass;
+    property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP;
+    property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
+    property HTTPTunnel: Boolean read FHTTPTunnel;
+    property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser;
+    property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass;
   end;
 
   TUDPBlockSocket = class(TSocksBlockSocket)
@@ -570,8 +609,7 @@ const
 var
   x: Integer;
   s: string;
-  c: Char;
+  l: Integer;
-  r,l: Integer;
 begin
   s := '';
   l := Length(Terminator);
@@ -583,25 +621,9 @@ begin
     x := 0;
     if FBuffer = '' then
     begin
-      x := WaitingData;
+      FBuffer := RecvPacket(Timeout);
-      if x > MaxSize then
+      if FLastError <> 0 then
-        x := MaxSize;
+        Break;
-      if x <= 1 then
-      begin
-        c := Char(RecvByte(Timeout));
-        if FLastError <> 0 then
-          Break;
-        FBuffer := c;
-      end
-      else
-      begin
-        SetLength(FBuffer, x);
-        r := RecvBuffer(Pointer(FBuffer), x);
-        if FLastError <> 0 then
-          Break;
-        if r < x then
-          SetLength(FBuffer, r);
-      end;
     end;
     s := s + FBuffer;
     FBuffer := '';
@@ -617,10 +639,7 @@ begin
       Break;
     end;
   until x > 0;
-  if FLastError = 0 then
+  Result := s;
-    Result := s
-  else
-    Result := '';
   ExceptCheck;
 end;
 
@@ -691,6 +710,15 @@ begin
   Result := x;
 end;
 
+function TBlockSocket.WaitingDataEx: Integer;
+begin
+  if FBuffer <> '' then
+    Result := Length(FBuffer)
+  else
+    Result := WaitingData;
+end;
+
+
 procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
 var
   li: TLinger;
@@ -860,6 +888,14 @@ begin
     DoStatus(HR_CanWrite, '');
 end;
 
+function TBlockSocket.CanReadEx(Timeout: Integer): Boolean;
+begin
+  if FBuffer <> '' then
+    Result := True
+  else
+    Result := CanRead(Timeout);
+end;
+
 function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer;
 var
   Len: Integer;
@@ -1135,6 +1171,7 @@ begin
   FSocksLocalPort := '';
   FSocksRemoteIP := '';
   FSocksRemotePort := '';
+  FBypassFlag := False;
 end;
 
 function TSocksBlockSocket.SocksOpen: boolean;
@@ -1144,38 +1181,43 @@ var
 begin
   Result := False;
   FUsingSocks := False;
-  if FSocksUsername = '' then
+  FBypassFlag := True;
-    Buf := #5 + #1 + #0
+  try
-  else
+    if FSocksUsername = '' then
-    Buf := #5 + #2 + #2 +#0;
+      Buf := #5 + #1 + #0
-  SendString(Buf);
+    else
-  Buf := RecvPacket(FSocksTimeout);
+      Buf := #5 + #2 + #2 +#0;
-  FBuffer := Copy(Buf, 3, Length(buf) - 2);
+    SendString(Buf);
-  if Length(Buf) < 2 then
+    Buf := RecvPacket(FSocksTimeout);
-    Exit;
+    FBuffer := Copy(Buf, 3, Length(buf) - 2);
-  if Buf[1] <> #5 then
+    if Length(Buf) < 2 then
-    Exit;
+      Exit;
-  n := Ord(Buf[2]);
+    if Buf[1] <> #5 then
-  case n of
+      Exit;
-    0: //not need authorisation
+    n := Ord(Buf[2]);
-      ;
+    case n of
-    2:
+      0: //not need authorisation
-      begin
+        ;
-        Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername
+      2:
-          + char(Length(FSocksPassword)) + FSocksPassword;
+        begin
-        SendString(Buf);
+          Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername
-        Buf := RecvPacket(FSocksTimeout);
+            + char(Length(FSocksPassword)) + FSocksPassword;
-        FBuffer := Copy(Buf, 3, Length(buf) - 2);
+          SendString(Buf);
-        if Length(Buf) < 2 then
+          Buf := RecvPacket(FSocksTimeout);
-          Exit;
+          FBuffer := Copy(Buf, 3, Length(buf) - 2);
-        if Buf[2] <> #0 then
+          if Length(Buf) < 2 then
-          Exit;
+            Exit;
-      end;
+          if Buf[2] <> #0 then
-  else
+            Exit;
-    Exit;
+        end;
+    else
+      Exit;
+    end;
+    FUsingSocks := True;
+    Result := True;
+  finally
+    FBypassFlag := False;
   end;
-  FUsingSocks := True;
-  Result := True;
 end;
 
 function TSocksBlockSocket.SocksRequest(Cmd: Byte;
@@ -1184,9 +1226,14 @@ var
   Buf: string;
 begin
   Result := False;
-  Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port);
+  FBypassFlag := True;
-  SendString(Buf);
+  try
-  Result := FLastError = 0;
+    Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port);
+    SendString(Buf);
+    Result := FLastError = 0;
+  finally
+    FBypassFlag := False;
+  end;
 end;
 
 function TSocksBlockSocket.SocksResponse: Boolean;
@@ -1195,21 +1242,26 @@ var
   x: integer;
 begin
   Result := False;
-  FSocksResponseIP := '';
+  FBypassFlag := True;
-  FSocksResponsePort := '';
+  try
-  Buf := RecvPacket(FSocksTimeout);
+    FSocksResponseIP := '';
-  if FLastError <> 0 then
+    FSocksResponsePort := '';
-    Exit;
+    Buf := RecvPacket(FSocksTimeout);
-  if Length(Buf) < 5 then
+    if FLastError <> 0 then
-    Exit;
+      Exit;
-  if Buf[1] <> #5 then
+    if Length(Buf) < 5 then
-    Exit;
+      Exit;
-  FSocksLastError := Ord(Buf[2]);
+    if Buf[1] <> #5 then
-  if FSocksLastError <> 0 then
+      Exit;
-    Exit;
+    FSocksLastError := Ord(Buf[2]);
-  x := SocksDecode(Buf);
+    if FSocksLastError <> 0 then
-  FBuffer := Copy(Buf, x, Length(buf) - x + 1);
+      Exit;
-  Result := True;
+    x := SocksDecode(Buf);
+    FBuffer := Copy(Buf, x, Length(buf) - x + 1);
+    Result := True;
+  finally
+    FBypassFlag := False;
+  end;
 end;
 
 function TSocksBlockSocket.SocksCode(IP, Port: string): string;
@@ -1407,6 +1459,29 @@ end;
 
 {======================================================================}
 
+constructor TTCPBlockSocket.Create;
+begin
+  inherited Create;
+  FSslEnabled := False;
+  FSslBypass := False;
+  FSsl := nil;
+  Fctx := nil;
+  FHTTPTunnelIP := '';
+  FHTTPTunnelPort := '';
+  FHTTPTunnel := False;
+  FHTTPTunnelRemoteIP := '';
+  FHTTPTunnelRemotePort := '';
+  FHTTPTunnelUser := '';
+  FHTTPTunnelPass := '';
+end;
+
+destructor TTCPBlockSocket.Destroy;
+begin
+  if FSslEnabled then
+    SslEnabled := False;
+  inherited;
+end;
+
 procedure TTCPBlockSocket.CreateSocket;
 begin
   FSocket := synsock.Socket(PF_INET, Integer(SOCK_STREAM), IPPROTO_TCP);
@@ -1478,28 +1553,88 @@ begin
 end;
 
 procedure TTCPBlockSocket.Connect(IP, Port: string);
+begin
+  if FSocksIP <> '' then
+    SocksDoConnect(IP, Port)
+  else
+    if FHTTPTunnelIP <> '' then
+      HTTPTunnelDoConnect(IP, Port)
+    else
+      inherited Connect(IP, Port);
+  if FSslEnabled then
+    SSLDoConnect;
+end;
+
+procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string);
 var
   b: Boolean;
 begin
-  if FSocksIP = '' then
+  inherited Connect(FSocksIP, FSocksPort);
-    inherited Connect(IP, Port)
+  b := SocksOpen;
-  else
+  if b then
-  begin
+    b := SocksRequest(1, IP, Port);
-    inherited Connect(FSocksIP, FSocksPort);
+  if b then
-    b := SocksOpen;
+    b := SocksResponse;
-    if b then
+  if not b and (FLastError = 0) then
-      b := SocksRequest(1, IP, Port);
+    FLastError := WSASYSNOTREADY;
-    if b then
+  FSocksLocalIP := FSocksResponseIP;
-      b := SocksResponse;
+  FSocksLocalPort := FSocksResponsePort;
-    if not b and (FLastError = 0) then
+  FSocksRemoteIP := IP;
-      FLastError := WSANO_RECOVERY;
+  FSocksRemotePort := Port;
-    FSocksLocalIP := FSocksResponseIP;
+  ExceptCheck;
-    FSocksLocalPort := FSocksResponsePort;
+  DoStatus(HR_Connect, IP + ':' + Port);
-    FSocksRemoteIP := IP;
+end;
-    FSocksRemotePort := Port;
+
-    ExceptCheck;
+procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string);
-    DoStatus(HR_Connect, IP + ':' + Port);
+var
+  s: string;
+begin
+  try
+    FBypassFlag := True;
+    inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort);
+    FHTTPTunnel := False;
+    SendString('CONNECT ' + IP + ':' + Port + 'HTTP/1.0' + #$0d + #$0a);
+    if FHTTPTunnelUser <> '' then
+    Sendstring('Proxy-Authorization: Basic ' +
+      EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a);
+    SendString(#$0d + #$0a);
+    repeat
+      s := RecvString(30000);
+      if FLastError <> 0 then
+        Break;
+      if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then
+        FHTTPTunnel := s[10] = '2';
+    until s = '';
+    if (FLasterror = 0) and not FHTTPTunnel then
+      FLastError := WSASYSNOTREADY;
+    FHTTPTunnelRemoteIP := IP;
+    FHTTPTunnelRemotePort := Port;
+  finally
+    FBypassFlag := False;
   end;
+  ExceptCheck;
+end;
+
+procedure TTCPBlockSocket.SSLDoConnect;
+begin
+  FLastError := 0;
+  if not FSSLEnabled then
+    SSLEnabled := True;
+  if sslsetfd(FSsl, FSocket) < 0 then
+    FLastError := WSASYSNOTREADY;
+  if (FLastError = 0) then
+    if sslconnect(FSsl) < 0 then
+      FLastError := WSASYSNOTREADY;
+  ExceptCheck;
+end;
+
+procedure TTCPBlockSocket.SSLDoShutdown;
+begin
+  FLastError := 0;
+  if sslshutdown(FSsl) < 0 then
+    FLastError := WSASYSNOTREADY;
+  ExceptCheck;
+  SSLEnabled := False;
 end;
 
 function TTCPBlockSocket.GetLocalSinIP: string;
@@ -1515,7 +1650,10 @@ begin
   if FUsingSocks then
     Result := FSocksRemoteIP
   else
-    Result := inherited GetRemoteSinIP;
+    if FHTTPTunnel then
+      Result := FHTTPTunnelRemoteIP
+    else
+      Result := inherited GetRemoteSinIP;
 end;
 
 function TTCPBlockSocket.GetLocalSinPort: Integer;
@@ -1531,7 +1669,158 @@ begin
   if FUsingSocks then
     Result := StrToIntDef(FSocksRemotePort, 0)
   else
-    Result := inherited GetRemoteSinPort;
+    if FHTTPTunnel then
+      Result := StrToIntDef(FHTTPTunnelRemotePort, 0)
+    else
+      Result := inherited GetRemoteSinPort;
+end;
+
+procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean);
+begin
+  if Value <> FSslEnabled then
+    if Value then
+    begin
+      if InitSSLInterface then
+      begin
+        SslLoadErrorStrings;
+        SslLibraryInit;
+        Fctx := nil;
+        Fctx := SslCtxNew(SslMethodV23);
+        Fssl := nil;
+        Fssl := SslNew(Fctx);
+        FSslEnabled := True;
+      end
+      else DestroySSLInterface;
+    end
+    else
+    begin
+      sslfree(Fssl);
+      SslCtxFree(Fctx);
+      DestroySSLInterface;
+      FSslEnabled := False;
+    end;
+end;
+
+function TTCPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer;
+var
+  err: integer;
+begin
+  if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then
+  begin
+    FLastError := 0;
+    repeat
+      Result := SslRead(FSsl, Buffer, Length);
+      err := SslGetError(FSsl, Result);
+    until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE);
+    if err = SSL_ERROR_ZERO_RETURN then
+      Result := 0
+    else
+      if (err <> 0) then
+        FLastError := WSASYSNOTREADY;
+    ExceptCheck;
+    DoStatus(HR_ReadCount, IntToStr(Result));
+  end
+  else
+    Result := inherited RecvBuffer(Buffer, Length);
+end;
+
+function TTCPBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer;
+var
+  err: integer;
+begin
+  if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then
+  begin
+    FLastError := 0;
+    repeat
+      Result := SslWrite(FSsl, Buffer, Length);
+      err := SslGetError(FSsl, Result);
+    until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE);
+    if err = SSL_ERROR_ZERO_RETURN then
+      Result := 0
+    else
+      if (err <> 0) then
+        FLastError := WSASYSNOTREADY;
+    ExceptCheck;
+    DoStatus(HR_WriteCount, IntToStr(Result));
+  end
+  else
+    Result := inherited SendBuffer(Buffer, Length);
+end;
+
+function TTCPBlockSocket.SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean;
+begin
+  Result := False;
+  FLastError := 0;
+  if SslCtxUseCertificateFile(FCtx, PChar(Certificate), 1) < 0 then
+    FLastError := WSASYSNOTREADY;
+  if (FLastError = 0) then
+    if SslCtxUsePrivateKeyFile(FCtx, PChar(PrivateKey), 1) < 0 then
+      FLastError := WSASYSNOTREADY;
+  if (FLastError = 0) then
+    if sslsetfd(FSsl, FSocket) < 0 then
+      FLastError := WSASYSNOTREADY;
+  if (FLastError = 0) then
+    if sslAccept(FSsl) < 0 then
+      FLastError := WSASYSNOTREADY;
+  ExceptCheck;
+  Result := FLastError = 0;
+end;
+
+function TTCPBlockSocket.SSLGetSSLVersion: string;
+begin
+  Result := SSlGetVersion(FSsl);
+end;
+
+function TTCPBlockSocket.SSLGetPeerSubject: string;
+var
+  cert: PX509;
+  s: string;
+begin
+  cert := SSLGetPeerCertificate(Fssl);
+  setlength(s, 4096);
+  Result := SslX509NameOneline(SslX509GetSubjectName(cert), PChar(s), length(s));
+  SslX509Free(cert);
+end;
+
+function TTCPBlockSocket.SSLGetPeerIssuer: string;
+var
+  cert: PX509;
+  s: string;
+begin
+  cert := SSLGetPeerCertificate(Fssl);
+  setlength(s, 4096);
+  Result := SslX509NameOneline(SslX509GetIssuerName(cert), PChar(s), length(s));
+  SslX509Free(cert);
+end;
+
+function TTCPBlockSocket.SSLGetPeerSubjectHash: Cardinal;
+var
+  cert: PX509;
+begin
+  cert := SSLGetPeerCertificate(Fssl);
+  Result := SslX509NameHash(SslX509GetSubjectName(cert));
+  SslX509Free(cert);
+end;
+
+function TTCPBlockSocket.SSLGetPeerIssuerHash: Cardinal;
+var
+  cert: PX509;
+begin
+  cert := SSLGetPeerCertificate(Fssl);
+  Result := SslX509NameHash(SslX509GetIssuerName(cert));
+  SslX509Free(cert);
+end;
+
+function TTCPBlockSocket.SSLGetPeerFingerprint: string;
+var
+  cert: PX509;
+  x: integer;
+begin
+  cert := SSLGetPeerCertificate(Fssl);
+  setlength(Result, EVP_MAX_MD_SIZE);
+  SslX509Digest(cert, SslEvpMd5, PChar(Result), @x);
+  SetLength(Result, x);
+  SslX509Free(cert);
 end;
 
 {======================================================================}

ftpsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.002.000 |
+| Project : Delphree - Synapse                                   | 001.002.002 |
 |==============================================================================|
 | Content: FTP client                                                          |
 |==============================================================================|
@@ -506,6 +506,8 @@ begin
 end;
 
 function TFTPSend.List(Directory: string; NameList: Boolean): Boolean;
+var
+  x: integer;
 begin
   Result := False;
   FDataStream.Clear;
@@ -515,9 +517,11 @@ begin
     Exit;
   FTPCommand('TYPE A');
   if NameList then
-    FTPCommand('NLST' + Directory)
+    x := FTPCommand('NLST' + Directory)
   else
-    FTPCommand('LIST' + Directory);
+    x := FTPCommand('LIST' + Directory);
+  if (x div 100) <> 1 then
+    Exit;
   Result := DataRead(FDataStream);
   FDataStream.Seek(0, soFromBeginning);
 end;
@@ -638,7 +642,7 @@ end;
 
 function TFTPSend.NoOp: Boolean;
 begin
-  Result := FTPCommand('NOOP') = 250;
+  Result := (FTPCommand('NOOP') div 100) = 2;
 end;
 
 function TFTPSend.RenameFile(const OldName, NewName: string): Boolean;

httpsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.003.000 |
+| Project : Delphree - Synapse                                   | 003.000.000 |
 |==============================================================================|
 | Content: HTTP client                                                         |
 |==============================================================================|
@@ -157,6 +157,7 @@ var
   Prot, User, Pass, Host, Port, Path, Para, URI: string;
   n: Integer;
   s, su: string;
+  HttpTunnel: Boolean;
 begin
   {initial values}
   Result := False;
@@ -164,6 +165,26 @@ begin
   FResultString := '';
 
   URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
+
+  if UpperCase(Prot) = 'HTTPS' then
+  begin
+    FSock.SSLEnabled := True;
+    HttpTunnel := FProxyHost <> '';
+    FSock.HTTPTunnelIP := FProxyHost;
+    FSock.HTTPTunnelPort := FProxyPort;
+    FSock.HTTPTunnelUser := FProxyUser;
+    FSock.HTTPTunnelPass := FProxyPass;
+  end
+  else
+  begin
+    FSock.SSLEnabled := False;
+    HttpTunnel := False;
+    FSock.HTTPTunnelIP := '';
+    FSock.HTTPTunnelPort := '';
+    FSock.HTTPTunnelUser := '';
+    FSock.HTTPTunnelPass := '';
+  end;
+
   Sending := Document.Size > 0;
   {Headers for Sending data}
   status100 := Sending and (FProtocol = '1.1');
@@ -178,17 +199,17 @@ begin
   { setting KeepAlives }
   if not FKeepAlive then
     FHeaders.Insert(0, 'Connection: close');
-  { set target servers/proxy, authorisations, etc... }
+  { set target servers/proxy, authorizations, etc... }
   if User <> '' then
     FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(user + ':' + pass));
-  if (FProxyHost <> '') and (FProxyUser <> '') then
+  if (FProxyHost <> '') and (FProxyUser <> '') and not(HttpTunnel) then
     FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
       EncodeBase64(FProxyUser + ':' + FProxyPass));
   if Port<>'80' then
      FHeaders.Insert(0, 'Host: ' + Host + ':' + Port)
   else
      FHeaders.Insert(0, 'Host: ' + Host);
-  if FProxyHost <> '' then
+  if (FProxyHost <> '') and not(HttpTunnel)then
     URI := Prot + '://' + Host + ':' + Port + URI;
   if URI = '/*' then
     URI := '*';
@@ -196,15 +217,15 @@ begin
     FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
   else
     FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
-  if FProxyHost = '' then
+  if (FProxyHost <> '') and not(HttpTunnel) then
-  begin
-    FHTTPHost := Host;
-    FHTTPPort := Port;
-  end
-  else
   begin
     FHTTPHost := FProxyHost;
     FHTTPPort := FProxyPort;
+  end
+  else
+  begin
+    FHTTPHost := Host;
+    FHTTPPort := Port;
   end;
   if FHeaders[FHeaders.Count - 1] <> '' then
     FHeaders.Add('');

mimemess.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.007.000 |
+| Project : Delphree - Synapse                                   | 001.007.002 |
 |==============================================================================|
 | Content: MIME message object                                                 |
 |==============================================================================|
@@ -43,6 +43,7 @@ type
     FOrganization: string;
     FCustomHeaders: TStringList;
     FDate: TDateTime;
+    FXMailer: string;
   public
     constructor Create;
     destructor Destroy; override;
@@ -59,6 +60,7 @@ type
     property Organization: string read FOrganization Write FOrganization;
     property CustomHeaders: TStringList read FCustomHeaders;
     property Date: TDateTime read FDate Write FDate;
+    property XMailer: string read FXMailer Write FXMailer;
   end;
 
   TMimeMess = class(TObject)
@@ -118,28 +120,45 @@ begin
   FOrganization := '';
   FCustomHeaders.Clear;
   FDate := 0;
+  FXMailer := '';
 end;
 
 procedure TMessHeader.EncodeHeaders(const Value: TStringList);
 var
   n: Integer;
+  s: string;
 begin
   if FDate = 0 then
     FDate := Now;
   for n := FCustomHeaders.Count - 1 downto 0 do
     if FCustomHeaders[n] <> '' then
       Value.Insert(0, FCustomHeaders[n]);
-  Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
+  if FXMailer = '' then
+    Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer')
+  else
+    Value.Insert(0, 'x-mailer: ' + FXMailer);
   Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
   if FOrganization <> '' then
     Value.Insert(0, 'Organization: ' + InlineCode(FOrganization));
+  s := '';
   for n := 0 to FCCList.Count - 1 do
-    Value.Insert(0, 'CC: ' + InlineEmail(FCCList[n]));
+    if s = '' then
+      s := InlineEmail(FCCList[n])
+    else
+      s := s + ' , ' + InlineEmail(FCCList[n]);
+  if s <> '' then
+    Value.Insert(0, 'CC: ' + s);
   Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
   if FSubject <> '' then
     Value.Insert(0, 'Subject: ' + InlineCode(FSubject));
+  s := '';
   for n := 0 to FToList.Count - 1 do
-    Value.Insert(0, 'To: ' + InlineEmail(FToList[n]));
+    if s = '' then
+      s := InlineEmail(FToList[n])
+    else
+      s := s + ' , ' + InlineEmail(FToList[n]);
+  if s <> '' then
+    Value.Insert(0, 'To: ' + s);
   Value.Insert(0, 'From: ' + InlineEmail(FFrom));
 end;
 
@@ -157,6 +176,11 @@ begin
     s := NormalizeHeader(Value, x);
     if s = '' then
       Break;
+    if Pos('X-MAILER:', UpperCase(s)) = 1 then
+    begin
+      FXMailer := SeparateRight(s, ':');
+      continue;
+    end;
     if Pos('FROM:', UpperCase(s)) = 1 then
     begin
       FFrom := InlineDecode(SeparateRight(s, ':'), cp);

mimepart.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.007.000 |
+| Project : Delphree - Synapse                                   | 001.008.001 |
 |==============================================================================|
 | Content: MIME support procedures and functions                               |
 |==============================================================================|
@@ -57,6 +57,7 @@ type
     FFileName: string;
     FLines: TStringList;
     FDecodedLines: TMemoryStream;
+    FSkipLast: Boolean;
     procedure SetPrimary(Value: string);
     procedure SetEncoding(Value: string);
     procedure SetCharset(Value: string);
@@ -85,6 +86,7 @@ type
     property FileName: string read FFileName Write FFileName;
     property Lines: TStringList read FLines;
     property DecodedLines: TMemoryStream read FDecodedLines;
+    property SkipLast: Boolean read FSkipLast Write FSkipLast;
   end;
 
 const
@@ -160,6 +162,7 @@ begin
   FDecodedLines := TMemoryStream.Create;
   FTargetCharset := GetCurCP;
   FDefaultCharset := 'US-ASCII';
+  FSkipLast := True;
 end;
 
 destructor TMIMEPart.Destroy;
@@ -341,7 +344,10 @@ begin
         begin
           s := TrimRight(s);
           if s = ('--' + b + '--') then
-            Result := Value.Count - 1;
+            if FSkipLast then
+              Result := Value.Count - 1
+            else
+              Result := n + 1;
           Break;
         end;
       end;

smtpsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.001.004 |
+| Project : Delphree - Synapse                                   | 002.002.000 |
 |==============================================================================|
 | Content: SMTP client                                                         |
 |==============================================================================|
@@ -455,19 +455,32 @@ function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
   const MailData: TStrings; const Username, Password: string): Boolean;
 var
   SMTP: TSMTPSend;
+  s, t: string;
 begin
   Result := False;
   SMTP := TSMTPSend.Create;
   try
-    SMTP.SMTPHost := SMTPHost;
+    SMTP.SMTPHost := SeparateLeft(SMTPHost, ':');
+    s := SeparateRight(SMTPHost, ':');
+    if (s <> '') and (s <> SMTPHost) then
+      SMTP.SMTPPort := s;
     SMTP.Username := Username;
     SMTP.Password := Password;
     if SMTP.Login then
     begin
-      if SMTP.MailFrom(MailFrom, Length(MailData.Text)) then
+      if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then
-        if SMTP.MailTo(MailTo) then
+      begin
-          if SMTP.MailData(MailData) then
+        s := MailTo;
-            Result := True;
+        repeat
+          t := GetEmailAddr(fetch(s, ','));
+          if t <> '' then
+            Result := SMTP.MailTo(t);
+          if not Result then
+            Break;
+        until s = '';
+        if Result then
+          Result := SMTP.MailData(MailData);
+      end;
       SMTP.Logout;
     end;
   finally
@@ -484,7 +497,7 @@ begin
   try
     t.Assign(MailData);
     t.Insert(0, '');
-    t.Insert(0, 'x-mailer: Synapse - Delphi TCP/IP library by Lukas Gebauer');
+    t.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
     t.Insert(0, 'subject: ' + Subject);
     t.Insert(0, 'date: ' + Rfc822DateTime(now));
     t.Insert(0, 'to: ' + MailTo);

synacode.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.005.002 |
+| Project : Delphree - Synapse                                   | 001.005.003 |
 |==============================================================================|
 | Content: Coding and decoding support                                         |
 |==============================================================================|
@@ -240,7 +240,9 @@ begin
         s := Copy(Value, x, 2);
         Inc(x, 2);
         if pos(#13, s) + pos(#10, s) = 0 then
-          Result[l] := Char(StrToIntDef('$' + s, 32));
+          Result[l] := Char(StrToIntDef('$' + s, 32))
+        else
+          Result[l] := ' ';
       end;
     Inc(l);
   end;

synautil.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.007.001 |
+| Project : Delphree - Synapse                                   | 002.008.001 |
 |==============================================================================|
 | Content: support procedures and functions                                    |
 |==============================================================================|
@@ -462,23 +462,34 @@ end;
 
 function IsIP(const Value: string): Boolean;
 var
-  n, x: Integer;
+  n, x, i: Integer;
 begin
   Result := true;
-  x := 0;
+  if Pos('..',Value) > 0 then
-  for n := 1 to Length(Value) do
+    Result := False
-    if not (Value[n] in ['0'..'9', '.']) then
+  else
+  begin
+    i := 0;
+    x := 0;
+    for n := 1 to Length(Value) do
     begin
-      Result := False;
+      if (Value[n] in ['0'..'9']) then
-      Break;
+        i := i +1
-    end
+      else
-    else
+        if (Value[n] in ['.']) then
-    begin
+          i := 0
-      if Value[n] = '.' then
+        else
-        Inc(x);
+          Result := False;
+      if Value[n] = '.'
+        then Inc(x);
+      if i > 3 then
+        result := False;
+      if result = false then
+        Break;
     end;
-  if x <> 3 then
+    if x <> 3 then
-    Result := False;
+      Result := False;
+  end;
 end;
 
 {==============================================================================}
@@ -742,6 +753,10 @@ begin
   end
   else
     sURL := URL;
+  if UpperCase(Prot) = 'HTTPS' then
+    Port := '443';
+  if UpperCase(Prot) = 'FTP' then
+    Port := '21';
   x := Pos('@', sURL);
   if (x > 0) and (x < Pos('/', sURL)) then
   begin