Release 36

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

asn1util.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.004.003 |
+| Project : Ararat Synapse                                       | 001.004.004 |
 |==============================================================================|
 | Content: support for ASN.1 BER coding and decoding                           |
 |==============================================================================|
@@ -53,7 +53,7 @@ Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL,
  ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER,
  ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE
 
-For sample of using, look to @link(TSnmpSend) class.
+For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class.
 }
 
 {$Q-}
@@ -67,7 +67,7 @@ unit asn1util;
 interface
 
 uses
-  SysUtils, Classes, SynaUtil;
+  SysUtils, Classes, synautil;
 
 const
   ASN1_BOOL = $01;

dnssend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.006.000 |
+| Project : Ararat Synapse                                       | 002.007.000 |
 |==============================================================================|
 | Content: DNS client                                                          |
 |==============================================================================|
@@ -100,6 +100,7 @@ const
   QTYPE_SRV = 33;
   QTYPE_NAPTR = 35; // RFC-2168
   QTYPE_KX = 36;
+  QTYPE_SPF = 99;
 
   QTYPE_AXFR = 252;
   QTYPE_MAILB = 253; //
@@ -453,7 +454,7 @@ begin
           R := IntToStr(x);
           R := R + ',' + DecodeLabels(j);
         end;
-      QTYPE_TXT:
+      QTYPE_TXT, QTYPE_SPF:
         begin
           R := '';
           while j < i do

ftpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 003.001.002 |
+| Project : Ararat Synapse                                       | 003.004.005 |
 |==============================================================================|
 | Content: FTP client                                                          |
 |==============================================================================|
-| Copyright (c)1999-2004, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2004.               |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2005.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -59,9 +59,6 @@ interface
 
 uses
   SysUtils, Classes,
-  {$IFDEF STREAMSEC}
-  TlsInternalServer, TlsSynaSock,
-  {$ENDIF}
   blcksock, synautil, synsock;
 
 const
@@ -198,14 +195,8 @@ type
   TFTPSend = class(TSynaClient)
   protected
     FOnStatus: TFTPStatus;
-    {$IFDEF STREAMSEC}
-    FSock: TSsTCPBlockSocket;
-    FDSock: TSsTCPBlockSocket;
-    FTLSServer: TCustomTLSInternalServer;
-    {$ELSE}
     FSock: TTCPBlockSocket;
     FDSock: TTCPBlockSocket;
-    {$ENDIF}
     FResultCode: Integer;
     FResultString: string;
     FFullResult: TStringList;
@@ -274,6 +265,11 @@ type
      Sock.OnStatus event, or from another thread.)}
     procedure Abort; virtual;
 
+    {:Break current transmission of data. It is same as Abort, but it send abort
+     telnet commands prior ABOR FTP command. Some servers need it. (You can call
+     this method from Sock.OnStatus event, or from another thread.)}
+    procedure TelnetAbort; virtual;
+
     {:Download directory listing of Directory on FTP server. If Directory is
      empty string, download listing of current working directory.
      If NameList is @true, download only names of files in directory.
@@ -367,11 +363,7 @@ type
      predefined firewall login sequences are described by comments in source
      file where you can see pseudocode decribing each sequence.}
     property FWMode: integer read FFWMode Write FFWMode;
-{$IFDEF STREAMSEC}
+
-    property Sock: TSsTCPBlockSocket read FSock;
-    property DSock: TSsTCPBlockSocket read FDSock;
-    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
-{$ELSE}
     {:Socket object used for TCP/IP operation on control channel. Good for
      seting OnStatus hook, etc.}
     property Sock: TTCPBlockSocket read FSock;
@@ -379,7 +371,6 @@ type
     {:Socket object used for TCP/IP operation on data channel. Good for seting
      OnStatus hook, etc.}
     property DSock: TTCPBlockSocket read FDSock;
-{$ENDIF}
 
     {:If you not use @link(DirectFile) mode, all data transfers is made to or
      from this stream.}
@@ -470,18 +461,9 @@ begin
   inherited Create;
   FFullResult := TStringList.Create;
   FDataStream := TMemoryStream.Create;
-{$IFDEF STREAMSEC}
-  FTLSServer := GlobalTLSInternalServer;
-  FSock := TSsTCPBlockSocket.Create;
-  FSock.BlockingRead := True;
-  FSock.ConvertLineEnd := True;
-  FDSock := TSsTCPBlockSocket.Create;
-  FDSock.BlockingRead := True;
-{$ELSE}
   FSock := TTCPBlockSocket.Create;
   FSock.ConvertLineEnd := True;
   FDSock := TTCPBlockSocket.Create;
-{$ENDIF}
   FFtpList := TFTPList.Create;
   FTimeout := 300000;
   FTargetPort := cFtpProtocol;
@@ -545,6 +527,7 @@ end;
 
 function TFTPSend.FTPCommand(const Value: string): integer;
 begin
+  FSock.Purge;
   FSock.SendString(Value + CRLF);
   DoStatus(False, Value);
   Result := ReadResult;
@@ -735,28 +718,14 @@ function TFTPSend.Connect: Boolean;
 begin
   FSock.CloseSocket;
   FSock.Bind(FIPInterface, cAnyPort);
-{$IFDEF STREAMSEC}
-  if FFullSSL then
-  begin
-    if assigned(FTLSServer) then
-      FSock.TLSServer := FTLSServer
-    else
-    begin
-      result := False;
-      Exit;
-    end;
-  end
-  else
-    FSock.TLSServer := nil;
-{$ELSE}
-  if FFullSSL then
-    FSock.SSLEnabled := True;
-{$ENDIF}
   if FSock.LastError = 0 then
     if FFWHost = '' then
       FSock.Connect(FTargetHost, FTargetPort)
     else
       FSock.Connect(FFWHost, FFWPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
   Result := FSock.LastError = 0;
 end;
 
@@ -778,20 +747,8 @@ begin
   if FAutoTLS and not(FIsTLS) then
     if (FTPCommand('AUTH TLS') div 100) = 2 then
     begin
-{$IFDEF STREAMSEC}
-      if Assigned(FTLSServer) then
-      begin
-        Fsock.TLSServer := FTLSServer;
-        Fsock.Connect('','');
-        FIsTLS := FSock.LastError = 0;
-      end;
-{$ELSE}
       FSock.SSLDoConnect;
       FIsTLS := FSock.LastError = 0;
-      FDSock.SSLCertificateFile := FSock.SSLCertificateFile;
-      FDSock.SSLPrivateKeyFile := FSock.SSLPrivateKeyFile;
-      FDSock.SSLCertCAFile := FSock.SSLCertCAFile;
-{$ENDIF}
       if not FIsTLS then
       begin
         Result := False;
@@ -878,6 +835,8 @@ var
   s: string;
 begin
   Result := False;
+  if FIsDataTLS then
+    FPassiveMode := True;
   if FPassiveMode then
   begin
     if FSock.IP6used then
@@ -958,19 +917,9 @@ begin
   end;
   if Result and FIsDataTLS then
   begin
-{$IFDEF STREAMSEC}
+    FDSock.SSL.Assign(FSock.SSL);
-    if Assigned(FTLSServer) then
-    begin
-      FDSock.TLSServer := FTLSServer;
-      FDSock.Connect('','');
-      Result := FDSock.LastError = 0;
-    end
-    else
-      Result := False;
-{$ELSE}
     FDSock.SSLDoConnect;
     Result := FDSock.LastError = 0;
-{$ENDIF}
   end;
 end;
 
@@ -994,17 +943,17 @@ end;
 function TFTPSend.DataWrite(const SourceStream: TStream): Boolean;
 var
   x: integer;
+  b: Boolean;
 begin
   Result := False;
   try
     if not AcceptDataSocket then
       Exit;
     FDSock.SendStreamRaw(SourceStream);
-    if FDSock.LastError <> 0 then
+    b := FDSock.LastError = 0;
-      Exit;
     FDSock.CloseSocket;
     x := ReadResult;
-    Result := (x div 100) = 2;
+    Result := b and ((x div 100) = 2);
   finally
     FDSock.CloseSocket;
   end;
@@ -1221,9 +1170,16 @@ end;
 
 procedure TFTPSend.Abort;
 begin
+  FSock.SendString('ABOR' + CRLF);
   FDSock.StopFlag := True;
 end;
 
+procedure TFTPSend.TelnetAbort;
+begin
+  FSock.SendString(#$FF + #$F4 + #$FF + #$F2);
+  Abort;
+end;
+
 {==============================================================================}
 
 procedure TFTPListRec.Assign(Value: TFTPListRec);
@@ -1570,7 +1526,7 @@ begin
       Exit;
     for n := 1 to 10 do
       if not(Permissions[n] in
-        ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 'w', 'x', 'y', '-']) then
+        ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then
         Exit;
   end;
   if Day <> '' then

httpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 003.009.005 |
+| Project : Ararat Synapse                                       | 003.010.001 |
 |==============================================================================|
 | Content: HTTP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2004, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2004.               |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2005.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -58,9 +58,6 @@ interface
 
 uses
   SysUtils, Classes,
-  {$IFDEF STREAMSEC}
-  TlsInternalServer, TlsSynaSock,
-  {$ENDIF}
   blcksock, synautil, synacode;
 
 const
@@ -74,12 +71,7 @@ type
   {:abstract(Implementation of HTTP protocol.)}
   THTTPSend = class(TSynaClient)
   protected
-    {$IFDEF STREAMSEC}
-    FSock: TSsTCPBlockSocket;
-    FTLSServer: TCustomTLSInternalServer;
-    {$ELSE}
     FSock: TTCPBlockSocket;
-    {$ENDIF}
     FTransferEncoding: TTransferEncoding;
     FAliveHost: string;
     FAlivePort: string;
@@ -206,13 +198,8 @@ type
      here total sice of uploaded data. It is good for draw upload progressbar
      from OnStatus event.}
     property UploadSize: integer read FUploadSize;
-{$IFDEF STREAMSEC}
-    property Sock: TSsTCPBlockSocket read FSock;
-    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
-{$ELSE}
     {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
     property Sock: TTCPBlockSocket read FSock;
-{$ENDIF}
   end;
 
 {:A very usefull function, and example of use can be found in the THTTPSend
@@ -264,13 +251,7 @@ begin
   FHeaders := TStringList.Create;
   FCookies := TStringList.Create;
   FDocument := TMemoryStream.Create;
-{$IFDEF STREAMSEC}
-  FTLSServer := GlobalTLSInternalServer;
-  FSock := TSsTCPBlockSocket.Create;
-  FSock.BlockingRead := True;
-{$ELSE}
   FSock := TTCPBlockSocket.Create;
-{$ENDIF}
   FSock.ConvertLineEnd := True;
   FSock.SizeRecvBuffer := c64k;
   FSock.SizeSendBuffer := c64k;
@@ -371,7 +352,6 @@ begin
   FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
   if Sending then
   begin
-//    FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
     if FMimeType <> '' then
       FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
   end;
@@ -441,19 +421,13 @@ begin
     FSock.Bind(FIPInterface, cAnyPort);
     if FSock.LastError <> 0 then
       Exit;
-{$IFDEF STREAMSEC}
-    FSock.TLSServer := nil;
-    if UpperCase(Prot) = 'HTTPS' then
-      if assigned(FTLSServer) then
-        FSock.TLSServer := FTLSServer
-      else
-        exit;
-{$ELSE}
-    FSock.SSLEnabled := UpperCase(Prot) = 'HTTPS';
-{$ENDIF}
     if FSock.LastError <> 0 then
       Exit;
     FSock.Connect(FTargetHost, FTargetPort);
+    if FSock.LastError <> 0 then
+      Exit;
+    if UpperCase(Prot) = 'HTTPS' then
+      FSock.SSLDoConnect;
     if FSock.LastError <> 0 then
       Exit;
     FAliveHost := FTargetHost;
@@ -467,19 +441,12 @@ begin
       FSock.Bind(FIPInterface, cAnyPort);
       if FSock.LastError <> 0 then
         Exit;
-{$IFDEF STREAMSEC}
-      FSock.TLSServer := nil;
-      if UpperCase(Prot) = 'HTTPS' then
-        if assigned(FTLSServer) then
-          FSock.TLSServer := FTLSServer
-        else
-          exit;
-{$ELSE}
-      FSock.SSLEnabled := UpperCase(Prot) = 'HTTPS';
-{$ENDIF}
       if FSock.LastError <> 0 then
         Exit;
       FSock.Connect(FTargetHost, FTargetPort);
+      if FSock.LastError = 0 then
+        if UpperCase(Prot) = 'HTTPS' then
+          FSock.SSLDoConnect;
       if FSock.LastError <> 0 then
       begin
         FSock.CloseSocket;
@@ -556,7 +523,6 @@ begin
       { old HTTP 0.9 and some buggy servers not send result }
       s := s + CRLF;
       WriteStrToStream(FDocument, s);
-//      FDocument.Write(Pointer(s)^, Length(s));
       FResultCode := 0;
     end;
   end
@@ -693,7 +659,8 @@ begin
   HTTP := THTTPSend.Create;
   try
     Result := HTTP.HTTPMethod('GET', URL);
-    Response.LoadFromStream(HTTP.Document);
+    if Result then
+      Response.LoadFromStream(HTTP.Document);
   finally
     HTTP.Free;
   end;
@@ -706,8 +673,11 @@ begin
   HTTP := THTTPSend.Create;
   try
     Result := HTTP.HTTPMethod('GET', URL);
-    Response.Seek(0, soFromBeginning);
+    if Result then
-    Response.CopyFrom(HTTP.Document, 0);
+    begin
+      Response.Seek(0, soFromBeginning);
+      Response.CopyFrom(HTTP.Document, 0);
+    end;
   finally
     HTTP.Free;
   end;
@@ -722,8 +692,11 @@ begin
     HTTP.Document.CopyFrom(Data, 0);
     HTTP.MimeType := 'Application/octet-stream';
     Result := HTTP.HTTPMethod('POST', URL);
-    Data.Seek(0, soFromBeginning);
+    if Result then
-    Data.CopyFrom(HTTP.Document, 0);
+    begin
+      Data.Seek(0, soFromBeginning);
+      Data.CopyFrom(HTTP.Document, 0);
+    end;
   finally
     HTTP.Free;
   end;
@@ -736,10 +709,10 @@ begin
   HTTP := THTTPSend.Create;
   try
     WriteStrToStream(HTTP.Document, URLData);
-//    HTTP.Document.Write(Pointer(URLData)^, Length(URLData));
     HTTP.MimeType := 'application/x-www-form-urlencoded';
     Result := HTTP.HTTPMethod('POST', URL);
-    Data.CopyFrom(HTTP.Document, 0);
+    if Result then
+      Data.CopyFrom(HTTP.Document, 0);
   finally
     HTTP.Free;
   end;
@@ -759,14 +732,13 @@ begin
     s := s + ' filename="' + FileName +'"' + CRLF;
     s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
     WriteStrToStream(HTTP.Document, s);
-//    HTTP.Document.Write(Pointer(s)^, Length(s));
     HTTP.Document.CopyFrom(Data, 0);
     s := CRLF + '--' + Bound + '--' + CRLF;
     WriteStrToStream(HTTP.Document, s);
-//    HTTP.Document.Write(Pointer(s)^, Length(s));
     HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
     Result := HTTP.HTTPMethod('POST', URL);
-    ResultData.LoadFromStream(HTTP.Document);
+    if Result then
+      ResultData.LoadFromStream(HTTP.Document);
   finally
     HTTP.Free;
   end;

imapsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.005.000 |
+| Project : Ararat Synapse                                       | 002.005.001 |
 |==============================================================================|
 | Content: IMAP4rev1 client                                                    |
 |==============================================================================|
@@ -58,9 +58,6 @@ interface
 
 uses
   SysUtils, Classes,
-  {$IFDEF STREAMSEC}
-  TlsInternalServer, TlsSynaSock,
-  {$ENDIF}
   blcksock, synautil;
 
 const
@@ -75,12 +72,7 @@ type
    parent @link(TSynaClient) too!}
   TIMAPSend = class(TSynaClient)
   protected
-    {$IFDEF STREAMSEC}
-    FSock: TSsTCPBlockSocket;
-    FTLSServer: TCustomTLSInternalServer;
-    {$ELSE}
     FSock: TTCPBlockSocket;
-    {$ENDIF}
     FTagCommand: integer;
     FResultString: string;
     FFullResult: TStringList;
@@ -264,13 +256,9 @@ type
     {:SSL/TLS mode is used from first contact to server. Servers with full
      SSL/TLS mode usualy using non-standard TCP port!}
     property FullSSL: Boolean read FFullSSL Write FFullSSL;
-{$IFDEF STREAMSEC}                            
+
-    property Sock: TSsTCPBlockSocket read FSock;
-    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
-{$ELSE}
     {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
     property Sock: TTCPBlockSocket read FSock;
-{$ENDIF}
   end;
 
 implementation
@@ -280,13 +268,7 @@ begin
   inherited Create;
   FFullResult := TStringList.Create;
   FIMAPcap := TStringList.Create;
-{$IFDEF STREAMSEC}           
-  FTLSServer := GlobalTLSInternalServer;
-  FSock := TSsTCPBlockSocket.Create;
-  FSock.BlockingRead := True;
-{$ELSE}
   FSock := TTCPBlockSocket.Create;
-{$ENDIF}
   FSock.ConvertLineEnd := True;
   FSock.SizeRecvBuffer := 32768;
   FSock.SizeSendBuffer := 32768;
@@ -519,25 +501,11 @@ function TIMAPSend.Connect: Boolean;
 begin
   FSock.CloseSocket;
   FSock.Bind(FIPInterface, cAnyPort);
-{$IFDEF STREAMSEC}
-  if FFullSSL then
-  begin
-    if assigned(FTLSServer) then
-      FSock.TLSServer := FTLSServer
-    else
-    begin
-      Result := false;
-      exit;
-    end;
-  end
-  else
-    FSock.TLSServer := nil;
-{$ELSE}
-  if FFullSSL then
-    FSock.SSLEnabled := True;
-{$ENDIF}
   if FSock.LastError = 0 then
     FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
   Result := FSock.LastError = 0;
 end;
 
@@ -773,6 +741,7 @@ begin
       begin
         t := SeparateRight(s, 'RFC822.SIZE ');
         t := Trim(SeparateLeft(t, ')'));
+        t := Trim(SeparateLeft(t, ' '));
         Result := StrToIntDef(t, -1);
         Break;
       end;
@@ -861,14 +830,7 @@ begin
   begin
     if IMAPcommand('STARTTLS') = 'OK' then
     begin
-{$IFDEF STREAMSEC}
-      if not assigned(FTLSServer) then
-        Exit;
-      Fsock.TLSServer := FTLSServer;
-      FSock.Connect('','');
-{$ELSE}
       Fsock.SSLDoConnect;
-{$ENDIF}
       Result := FSock.LastError = 0;
     end;
   end;

ldapsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.003.000 |
+| Project : Ararat Synapse                                       | 001.004.000 |
 |==============================================================================|
 | Content: LDAP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2004, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2003-2004.                |
+| Portions created by Lukas Gebauer are Copyright (c)2003-2005.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -58,9 +58,6 @@ interface
 
 uses
   SysUtils, Classes,
-  {$IFDEF STREAMSEC}
-  TlsInternalServer, TlsSynaSock,
-  {$ENDIF}
   blcksock, synautil, asn1util, synacode;
 
 const
@@ -197,12 +194,7 @@ type
    parent @link(TSynaClient) too!}
   TLDAPSend = class(TSynaClient)
   private
-    {$IFDEF STREAMSEC}
-    FSock: TSsTCPBlockSocket;
-    FTLSServer: TCustomTLSInternalServer;
-    {$ELSE}
     FSock: TTCPBlockSocket;
-    {$ENDIF}
     FResultCode: Integer;
     FResultString: string;
     FFullResult: string;
@@ -328,13 +320,9 @@ type
     {:When you call @link(Extended) operation, then here is result Value returned
      by server.}
     property ExtValue: string read FExtValue;
-{$IFDEF STREAMSEC}
+
-    property Sock: TSsTCPBlockSocket read FSock;
-    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
-{$ELSE}
     {:TCP socket used by all LDAP operations.}
     property Sock: TTCPBlockSocket read FSock;
-{$ENDIF}
   end;
 
 {:Dump result of LDAP SEARCH into human readable form. Good for debugging.}
@@ -487,13 +475,7 @@ begin
   inherited Create;
   FReferals := TStringList.Create;
   FFullResult := '';
-{$IFDEF STREAMSEC}
-  FTLSServer := GlobalTLSInternalServer;
-  FSock := TSsTCPBlockSocket.Create;
-  FSock.BlockingRead := True;
-{$ELSE}
   FSock := TTCPBlockSocket.Create;
-{$ENDIF}
   FTimeout := 60000;
   FTargetPort := cLDAPProtocol;
   FAutoTLS := False;
@@ -610,25 +592,11 @@ begin
   FSock.LineBuffer := '';
   FSeq := 0;
   FSock.Bind(FIPInterface, cAnyPort);
-{$IFDEF STREAMSEC}
-  if FFullSSL then
-  begin
-    if Assigned(FTLSServer) then
-      FSock.TLSServer := FTLSServer
-    else
-    begin
-      Result := false;
-      Exit;
-    end;
-  end
-  else
-    FSock.TLSServer := nil;
-{$ELSE}
-  if FFullSSL then
-    FSock.SSLEnabled := True;
-{$ENDIF}
   if FSock.LastError = 0 then
     FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
   Result := FSock.LastError = 0;
 end;
 
@@ -1166,19 +1134,8 @@ begin
   Result := Extended('1.3.6.1.4.1.1466.20037', '');
   if Result then
   begin
-{$IFDEF STREAMSEC}
-    if Assigned(FTLSServer) then
-    begin
-      Fsock.TLSServer := FTLSServer;
-      Fsock.Connect('','');
-      Result := FSock.LastError = 0;
-    end
-    else
-      Result := false;
-{$ELSE}
     Fsock.SSLDoConnect;
     Result := FSock.LastError = 0;
-{$ENDIF}
   end;
 end;
 

mimeinln.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.001.008 |
+| Project : Ararat Synapse                                       | 001.001.009 |
 |==============================================================================|
 | Content: Inline MIME support procedures and functions                        |
 |==============================================================================|
@@ -205,7 +205,7 @@ var
 begin
   Result := False;
   for n := 1 to Length(Value) do
-    if Value[n] in (SpecialChar + NonAsciiChar) then
+    if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
     begin
       Result := True;
       Break;

mimemess.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.004.003 |
+| Project : Ararat Synapse                                       | 002.005.000 |
 |==============================================================================|
 | Content: MIME message object                                                 |
 |==============================================================================|
-| Copyright (c)1999-2003, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2005.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -197,6 +197,17 @@ type
      properties. Content of part is readed from value stringlist.}
     function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
 
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to text part and set all necessary
+     properties. Content of part is readed from value stringlist. You can select
+     your charset and your encoding type. If Raw is @true, then it not doing
+     charset conversion!}
+    function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
+      PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
+
     {:Add MIME part as subpart of PartParent. If you need set root MIME part,
      then set as PartParent @NIL value. If you need set more then 1 subpart, you
      must have PartParent of multipart type!
@@ -627,6 +638,25 @@ begin
   end;
 end;
 
+function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
+  PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Value.SaveToStream(DecodedLines);
+    Primary := 'text';
+    Secondary := 'plain';
+    Description := 'Message text';
+    Disposition := 'inline';
+    CharsetCode := PartCharset;
+    EncodingCode := PartEncoding;
+    ConvertCharset := not Raw;
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
 function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
 begin
   Result := AddPart(PartParent);

mimepart.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.006.003 |
+| Project : Ararat Synapse                                       | 002.007.002 |
 |==============================================================================|
 | Content: MIME support procedures and functions                               |
 |==============================================================================|
-| Copyright (c)1999-2004, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2004.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2005.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -136,6 +136,8 @@ type
     FSubLevel: integer;
     FMaxSubLevel: integer;
     FAttachInside: boolean;
+    FConvertCharset: Boolean;
+    FForcedHTMLConvert: Boolean;
     procedure SetPrimary(Value: string);
     procedure SetEncoding(Value: string);
     procedure SetCharset(Value: string);
@@ -252,6 +254,14 @@ type
      operating system.}
     property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
 
+    {:If @true, then do internal charset translation of part content between @link(CharsetCode)
+     and @link(TargetCharset)}
+    property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset;
+
+    {:If @true, then allways do internal charset translation of HTML parts
+     by MIME even it have their own charset in META tag. Default is @false.}
+    property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert;
+
     {:Secondary Mime type of part. (i.e. 'mixed')}
     property Secondary: string read FSecondary Write FSecondary;
 
@@ -398,6 +408,8 @@ begin
   FSubLevel := 0;
   FMaxSubLevel := -1;
   FAttachInside := false;
+  FConvertCharset := true;
+  FForcedHTMLConvert := false;
 end;
 
 destructor TMIMEPart.Destroy;
@@ -436,6 +448,8 @@ begin
   FPrePart.Clear;
   FPostPart.Clear;
   FDecodedLines.Clear;
+  FConvertCharset := true;
+  FForcedHTMLConvert := false;
   ClearSubParts;
 end;
 
@@ -464,6 +478,7 @@ begin
   PostPart.Assign(Value.PostPart);
   MaxLineLength := Value.MaxLineLength;
   FAttachInside := Value.AttachInside;
+  FConvertCharset := Value.ConvertCharset;
 end;
 
 {==============================================================================}
@@ -744,22 +759,15 @@ begin
   else
     s := FPartBody.Text;
   end;
-  if FPrimaryCode = MP_TEXT then
+  if FConvertCharset and (FPrimaryCode = MP_TEXT) then
-    if uppercase(FSecondary) = 'HTML' then
+    if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then
     begin
-      b := False;
+      t := uppercase(s);
-      for n := 0 to FPartBody.Count - 1 do
+      t := SeparateLeft(t, '</HEAD>');
-      begin
+      t := SeparateRight(t, '<HEAD>');
-        t := uppercase(FPartBody[n]);
+      t := ReplaceString(t, '"', '');
-        if Pos('HTTP-EQUIV', t) > 0 then
+      t := ReplaceString(t, ' ', '');
-          if Pos('CONTENT-TYPE', t) > 0 then
+      b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
-          begin
-            b := True;
-            Break;
-          end;
-        if Pos('</HEAD>', t) > 0 then
-          Break;
-      end;
       if not b then
         s := CharsetConversion(s, FCharsetCode, FTargetCharset);
     end
@@ -841,7 +849,6 @@ var
   s, t: string;
   n, x: Integer;
   d1, d2: integer;
-  NeedBOM: Boolean;
 begin
   if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
     Encoding := 'base64';
@@ -849,92 +856,71 @@ begin
   FPartBody.Clear;
   FDecodedLines.Seek(0, soFromBeginning);
   try
-    NeedBOM := True;
     case FPrimaryCode of
       MP_MULTIPART, MP_MESSAGE:
         FPartBody.LoadFromStream(FDecodedLines);
       MP_TEXT, MP_BINARY:
-        if FEncodingCode = ME_BASE64 then
         begin
-          while FDecodedLines.Position < FDecodedLines.Size do
+          s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size);
+          if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then
+            s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode);
+          if FEncodingCode = ME_BASE64 then
           begin
-            s := ReadStrFromStream(FDecodedLines, 54);
+            x := 1;
-//            Setlength(s, 54);
+            while x <= length(s) do
-//            x := FDecodedLines.Read(pointer(s)^, 54);
-//            Setlength(s, x);
-            if FPrimaryCode = MP_TEXT then
             begin
-              s := CharsetConversion(s, FTargetCharset, FCharsetCode);
+              t := copy(s, x, 54);
-              if NeedBOM then
+              x := x + length(t);
-              begin
+              t := EncodeBase64(t);
-                s := GetBOM(FCharSetCode) + s;
+              FPartBody.Add(t);
-                NeedBOM := False;
-              end;
             end;
-            s := EncodeBase64(s);
-            FPartBody.Add(s);
-          end;
-        end
-        else
-        begin
-          if FPrimaryCode = MP_BINARY then
-          begin
-            s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size);
-//            SetLength(s, FDecodedLines.Size);
-//            x := FDecodedLines.Read(pointer(s)^, FDecodedLines.Size);
-//            Setlength(s, x);
-            l.Add(s);
           end
           else
-            l.LoadFromStream(FDecodedLines);
-          for n := 0 to l.Count - 1 do
           begin
-            s := l[n];
+            if FPrimaryCode = MP_BINARY then
-            if (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then
+              l.Add(s)
-            begin
-              s := CharsetConversion(s, FTargetCharset, FCharsetCode);
-              if NeedBOM then
-              begin
-                s := GetBOM(FCharSetCode) + s;
-                NeedBOM := False;
-              end;
-            end;
-            if FEncodingCode = ME_QUOTED_PRINTABLE then
-            begin
-              s := EncodeQuotedPrintable(s);
-              repeat
-                if Length(s) < FMaxLineLength then
-                begin
-                  t := s;
-                  s := '';
-                end
-                else
-                begin
-                  d1 := RPosEx('=', s, FMaxLineLength);
-                  d2 := RPosEx(' ', s, FMaxLineLength);
-                  if (d1 = 0) and (d2 = 0) then
-                    x := FMaxLineLength
-                  else
-                    if d1 > d2 then
-                      x := d1 - 1
-                    else
-                      x := d2 - 1;
-                  if x = 0 then
-                    x := FMaxLineLength;
-                  t := Copy(s, 1, x);
-                  Delete(s, 1, x);
-                  if s <> '' then
-                    t := t + '=';
-                end;
-                FPartBody.Add(t);
-              until s = '';
-            end
             else
-              FPartBody.Add(s);
+              l.Text := s;
+            for n := 0 to l.Count - 1 do
+            begin
+              s := l[n];
+              if FEncodingCode = ME_QUOTED_PRINTABLE then
+              begin
+                s := EncodeQuotedPrintable(s);
+                repeat
+                  if Length(s) < FMaxLineLength then
+                  begin
+                    t := s;
+                    s := '';
+                  end
+                  else
+                  begin
+                    d1 := RPosEx('=', s, FMaxLineLength);
+                    d2 := RPosEx(' ', s, FMaxLineLength);
+                    if (d1 = 0) and (d2 = 0) then
+                      x := FMaxLineLength
+                    else
+                      if d1 > d2 then
+                        x := d1 - 1
+                      else
+                        x := d2 - 1;
+                    if x = 0 then
+                      x := FMaxLineLength;
+                    t := Copy(s, 1, x);
+                    Delete(s, 1, x);
+                    if s <> '' then
+                      t := t + '=';
+                  end;
+                  FPartBody.Add(t);
+                until s = '';
+              end
+              else
+                FPartBody.Add(s);
+            end;
+            if (FPrimaryCode = MP_BINARY)
+              and (FEncodingCode = ME_QUOTED_PRINTABLE) then
+              FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '=';
           end;
-          if (FPrimaryCode = MP_BINARY)
-            and (FEncodingCode = ME_QUOTED_PRINTABLE) then
-            FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '=';
         end;
     end;
   finally
@@ -966,7 +952,7 @@ begin
   begin
     s := '';
     if FFileName <> '' then
-      s := '; FileName="' + InlineCodeEx(FileName, FTargetCharset) + '"';
+      s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
     FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
   end;
   if FContentID <> '' then
@@ -995,7 +981,7 @@ begin
       s := FPrimary + '/' + FSecondary;
   end;
   if FFileName <> '' then
-    s := s + '; name="' + InlineCodeEx(FileName, FTargetCharset) + '"';
+    s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
   FHeaders.Insert(0, 'Content-type: ' + s);
 end;
 

nntpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.004.001 |
+| Project : Ararat Synapse                                       | 001.005.000 |
 |==============================================================================|
 | Content: NNTP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2003, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2003.               |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2005.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -59,9 +59,6 @@ interface
 
 uses
   SysUtils, Classes,
-  {$IFDEF STREAMSEC}
-  TlsInternalServer, TlsSynaSock,
-  {$ENDIF}
   blcksock, synautil;
 
 const
@@ -78,12 +75,7 @@ type
    parent @link(TSynaClient) too!}
   TNNTPSend = class(TSynaClient)
   private
-    {$IFDEF STREAMSEC}
-    FSock: TSsTCPBlockSocket;
-    FTLSServer: TCustomTLSInternalServer;
-    {$ELSE}
     FSock: TTCPBlockSocket;
-    {$ENDIF}
     FResultCode: Integer;
     FResultString: string;
     FData: TStringList;
@@ -192,13 +184,9 @@ type
     {:SSL/TLS mode is used from first contact to server. Servers with full
      SSL/TLS mode usualy using non-standard TCP port!}
     property FullSSL: Boolean read FFullSSL Write FFullSSL;
-{$IFDEF STREAMSEC}
+
-    property Sock: TSsTCPBlockSocket read FSock;
-    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
-{$ELSE}
     {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
     property Sock: TTCPBlockSocket read FSock;
-{$ENDIF}
   end;
 
 implementation
@@ -206,13 +194,7 @@ implementation
 constructor TNNTPSend.Create;
 begin
   inherited Create;
-{$IFDEF STREAMSEC}
-  FTLSServer := GlobalTLSInternalServer;
-  FSock := TSsTCPBlockSocket.Create;
-  FSock.BlockingRead := True;
-{$ELSE}
   FSock := TTCPBlockSocket.Create;
-{$ENDIF}
   FData := TStringList.Create;
   FDataToSend := TStringList.Create;
   FNNTPcap := TStringList.Create;
@@ -288,25 +270,11 @@ function TNNTPSend.Connect: Boolean;
 begin
   FSock.CloseSocket;
   FSock.Bind(FIPInterface, cAnyPort);
-{$IFDEF STREAMSEC}
-  if FFullSSL then
-  begin
-    if assigned(FTLSServer) then
-      FSock.TLSServer := FTLSServer;
-    else
-    begin
-      result := False;
-      Exit;
-    end;
-  end
-  else
-    FSock.TLSServer := nil;
-{$ELSE}
-  if FFullSSL then
-    FSock.SSLEnabled := True;
-{$ENDIF}
   if FSock.LastError = 0 then
     FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
   Result := FSock.LastError = 0;
 end;
 
@@ -475,19 +443,8 @@ begin
   begin
     if DoCommand('STARTTLS') then
     begin
-{$IFDEF STREAMSEC}
-      if (Assigned(FTLSServer) then
-      begin
-        Fsock.TLSServer := FTLSServer;
-        Fsock.Connect('','');
-        Result := FSock.LastError = 0;
-      end
-      else
-        Result := False;
-{$ELSE}
       Fsock.SSLDoConnect;
       Result := FSock.LastError = 0;
-{$ENDIF}
     end;
   end;
 end;

pop3send.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.003.000 |
+| Project : Ararat Synapse                                       | 002.004.000 |
 |==============================================================================|
 | Content: POP3 client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2003, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2001-2003.                |
+| Portions created by Lukas Gebauer are Copyright (c)2001-2005.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -58,9 +58,6 @@ interface
 
 uses
   SysUtils, Classes,
-  {$IFDEF STREAMSEC}
-  TlsInternalServer, TlsSynaSock,
-  {$ENDIF}
   blcksock, synautil, synacode;
 
 const
@@ -81,12 +78,7 @@ type
    parent @link(TSynaClient) too!}
   TPOP3Send = class(TSynaClient)
   private
-    {$IFDEF STREAMSEC}
-    FSock: TSsTCPBlockSocket;
-    FTLSServer: TCustomTLSInternalServer;
-    {$ELSE}
     FSock: TTCPBlockSocket;
-    {$ENDIF}
     FResultCode: Integer;
     FResultString: string;
     FFullResult: TStringList;
@@ -186,13 +178,8 @@ type
     {:SSL/TLS mode is used from first contact to server. Servers with full
      SSL/TLS mode usualy using non-standard TCP port!}
     property FullSSL: Boolean read FFullSSL Write FFullSSL;
-{$IFDEF STREAMSEC}
-    property Sock: TSsTCPBlockSocket read FSock;
-    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
-{$ELSE}
     {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
     property Sock: TTCPBlockSocket read FSock;
-{$ENDIF}
   end;
 
 implementation
@@ -202,13 +189,7 @@ begin
   inherited Create;
   FFullResult := TStringList.Create;
   FPOP3cap := TStringList.Create;
-{$IFDEF STREAMSEC}           
-  FTLSServer := GlobalTLSInternalServer;     
-  FSock := TSsTCPBlockSocket.Create;
-  FSock.BlockingRead := True;
-{$ELSE}
   FSock := TTCPBlockSocket.Create;
-{$ENDIF}
   FSock.ConvertLineEnd := true;
   FTimeout := 60000;
   FTargetPort := cPop3Protocol;
@@ -277,25 +258,11 @@ begin
   FSock.CloseSocket;
   FSock.LineBuffer := '';
   FSock.Bind(FIPInterface, cAnyPort);
-{$IFDEF STREAMSEC}
-  if FFullSSL then
-  begin
-    if Assigned(FTLSServer) then
-      FSock.TLSServer := FTLSServer
-    else
-    begin
-      Result := false;
-      Exit;
-    end;
-  end
-  else
-    FSock.TLSServer := nil;
-{$ELSE}
-  if FFullSSL then
-    FSock.SSLEnabled := True;
-{$ENDIF}
   if FSock.LastError = 0 then
     FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
   Result := FSock.LastError = 0;
 end;
 
@@ -425,19 +392,8 @@ begin
   FSock.SendString('STLS' + CRLF);
   if ReadResult(False) = 1 then
   begin
-{$IFDEF STREAMSEC}
-    if Assigned(FTLSServer) then
-    begin
-      Fsock.TLSServer := FTLSServer;
-      Fsock.Connect('','');
-      Result := FSock.LastError = 0;
-    end
-    else
-      Result := false;
-{$ELSE}
     Fsock.SSLDoConnect;
     Result := FSock.LastError = 0;
-{$ENDIF}
   end;
 end;
 

slogsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.002.000 |
+| Project : Ararat Synapse                                       | 001.002.002 |
 |==============================================================================|
 | Content: SysLog client                                                       |
 |==============================================================================|
@@ -232,7 +232,7 @@ begin
   Inc(Pos);
   // Tag
   StrBuf := '';
-  while (Value[Pos] <> ' ')do
+  while (Value[Pos] <> ':')do
     begin
       StrBuf := StrBuf + Value[Pos];
       Inc(Pos);
@@ -246,7 +246,7 @@ begin
       StrBuf := StrBuf + Value[Pos];
       Inc(Pos);
     end;
-  FMessage := StrBuf;
+  FMessage := TrimSP(StrBuf);
 end;
 
 procedure TSysLogMessage.Clear;
@@ -293,10 +293,6 @@ begin
   FSysLogMessage.DateTime := Now;
   if Length(FSysLogMessage.PacketBuf) <= 1024 then
   begin
-    FSock.EnableReuse(True);
-    Fsock.Bind(FIPInterface, FTargetPort);
-    if FSock.LastError <> 0 then
-      FSock.Bind(FIPInterface, cAnyPort);
     FSock.Connect(FTargetHost, FTargetPort);
     FSock.SendString(FSysLogMessage.PacketBuf);
     Result := FSock.LastError = 0;

smtpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 003.003.001 |
+| Project : Ararat Synapse                                       | 003.004.002 |
 |==============================================================================|
 | Content: SMTP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2004, Lukas Gebauer                                        |
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2004.          |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2005.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -59,9 +59,6 @@ interface
 
 uses
   SysUtils, Classes,
-  {$IFDEF STREAMSEC}
-  TlsInternalServer, TlsSynaSock,
-  {$ENDIF}
   blcksock, synautil, synacode;
 
 const
@@ -78,12 +75,7 @@ type
    parent @link(TSynaClient) too!}
   TSMTPSend = class(TSynaClient)
   private
-    {$IFDEF STREAMSEC}
-    FSock: TSsTCPBlockSocket;
-    FTLSServer: TCustomTLSInternalServer;
-    {$ELSE}
     FSock: TTCPBlockSocket;
-    {$ENDIF}
     FResultCode: Integer;
     FResultString: string;
     FFullResult: TStringList;
@@ -210,13 +202,9 @@ type
     {:SSL/TLS mode is used from first contact to server. Servers with full
      SSL/TLS mode usualy using non-standard TCP port!}
     property FullSSL: Boolean read FFullSSL Write FFullSSL;
-{$IFDEF STREAMSEC}
+
-    property Sock: TSsTCPBlockSocket read FSock;
-    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
-{$ELSE}
     {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
     property Sock: TTCPBlockSocket read FSock;
-{$ENDIF}
   end;
 
 {:A very useful function and example of its use would be found in the TSMTPsend
@@ -271,13 +259,7 @@ begin
   inherited Create;
   FFullResult := TStringList.Create;
   FESMTPcap := TStringList.Create;
-{$IFDEF STREAMSEC}
-  FTLSServer := GlobalTLSInternalServer;
-  FSock := TSsTCPBlockSocket.Create;
-  FSock.BlockingRead := True;
-{$ELSE}
   FSock := TTCPBlockSocket.Create;
-{$ENDIF}
   FSock.ConvertLineEnd := true;
   FTimeout := 60000;
   FTargetPort := cSmtpProtocol;
@@ -383,25 +365,11 @@ function TSMTPSend.Connect: Boolean;
 begin
   FSock.CloseSocket;
   FSock.Bind(FIPInterface, cAnyPort);
-{$IFDEF STREAMSEC}
-  if FFullSSL then
-  begin
-    if assigned(FTLSServer) then
-      FSock.TLSServer := FTLSServer;
-    else
-    begin
-      result := False;
-      Exit;
-    end;
-  end
-  else
-    FSock.TLSServer := nil;
-{$ELSE}
-  if FFullSSL then
-    FSock.SSLEnabled := True;
-{$ENDIF}
   if FSock.LastError = 0 then
     FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
   Result := FSock.LastError = 0;
 end;
 
@@ -526,19 +494,30 @@ function TSMTPSend.MailData(const Value: TStrings): Boolean;
 var
   n: Integer;
   s: string;
+  t: string;
+  x: integer;
 begin
   Result := False;
   FSock.SendString('DATA' + CRLF);
   if ReadResult <> 354 then
     Exit;
+  t := '';
+  x := 1500;
   for n := 0 to Value.Count - 1 do
   begin
     s := Value[n];
     if Length(s) >= 1 then
       if s[1] = '.' then
         s := '.' + s;
-    FSock.SendString(s + CRLF);
+    if Length(t) + Length(s) >= x then
+    begin
+      FSock.SendString(t);
+      t := '';
+    end;
+    t := t + s + CRLF;
   end;
+  if t <> '' then
+    FSock.SendString(t);
   FSock.SendString('.' + CRLF);
   Result := ReadResult = 250;
 end;
@@ -569,19 +548,8 @@ begin
     FSock.SendString('STARTTLS' + CRLF);
     if (ReadResult = 220) and (FSock.LastError = 0) then
     begin
-{$IFDEF STREAMSEC}
-      if (Assigned(FTLSServer) then
-      begin
-        Fsock.TLSServer := FTLSServer;
-        Fsock.Connect('','');
-        Result := FSock.LastError = 0;
-      end
-      else
-        Result := False;
-{$ELSE}
       Fsock.SSLDoConnect;
       Result := FSock.LastError = 0;
-{$ENDIF}
     end;
   end;
 end;

snmpsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 003.000.007 |
+| Project : Ararat Synapse                                       | 003.000.008 |
 |==============================================================================|
 | Content: SNMP client                                                         |
 |==============================================================================|
@@ -1055,6 +1055,7 @@ begin
     SNMPSend.TargetPort := cSnmpTrapProtocol;
     if SNMPSend.RecvTrap then
     begin
+      Result := 1;
       Dest := SNMPSend.HostIP;
       Community := SNMPSend.Reply.Community;
       Source := SNMPSend.Reply.OldTrapHost;

sntpsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 003.000.000 |
+| Project : Ararat Synapse                                       | 003.000.001|
 |==============================================================================|
 | Content: SNTP client                                                         |
 |==============================================================================|
@@ -302,6 +302,7 @@ var
   x: Integer;
 begin
   Result := False;
+  FSock.CloseSocket;
   FSock.Bind(FIPInterface, cAnyPort);
   FSock.Connect(FTargetHost, FTargetPort);
   ClearNtp(q);
@@ -330,6 +331,7 @@ var
   t1, t2, t3, t4 : TDateTime;
 begin
   Result := False;
+  FSock.CloseSocket;
   FSock.Bind(FIPInterface, cAnyPort);
   FSock.Connect(FTargetHost, FTargetPort);
   ClearNtp(q);

ssl_cryptlib.pas

@@ -0,0 +1,535 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.002 |
+|==============================================================================|
+| Content: SSL/SSH support by Peter Gutmann's CryptLib                         |
+|==============================================================================|
+| 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):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SSL/SSH plugin for CryptLib)
+
+This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32
+and Linux. This library is staticly linked - when you compile your application
+with this plugin, you MUST distribute it with Cryptib library, otherwise you
+cannot run your application!
+
+It can work with keys and certificates stored as PKCS#15 only! It must be stored
+as disk file only, you cannot load them from memory! Each file can hold multiple
+keys and certificates. You must identify it by 'label' stored in
+@link(TSSLCryptLib.PrivateKeyLabel).
+
+If you need to use secure connection and authorize self by certificate
+(each SSL/TLS server or client with client authorization), then use
+@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and
+@link(TCustomSSL.KeyPassword) properties.
+
+If you need to use server what verifying client certificates, then use
+@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients
+with non-matching certificates will be rejected by cryptLib.
+
+This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
+server without explicitly assigned key and certificate, then this plugin create
+Ad-Hoc key and certificate for each incomming connection by self. It slowdown
+accepting of new connections!
+
+You can use this plugin for SSHv2 connections too! You must explicitly set
+@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username)
+and @link(TCustomSSL.password). You can use special SSH channels too, see
+@link(TCustomSSL).
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_cryptlib;
+
+interface
+
+uses
+  SysUtils,
+  blcksock, synsock, synautil, synacode,
+  cryptlib;
+
+type
+  {:@abstract(class implementing CryptLib SSL/SSH 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!}
+  TSSLCryptLib = class(TCustomSSL)
+  protected
+    FCryptSession: CRYPT_SESSION;
+    FPrivateKeyLabel: string;
+    FDelCert: Boolean;
+    function SSLCheck(Value: integer): Boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
+    function CreateSelfSignedCert(Host: string): Boolean; override;
+  public
+    {:See @inherited}
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited}
+    procedure Assign(const Value: TCustomSSL); override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_cryptlib) 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;
+  published
+    {:name of certificate/key within PKCS#15 file. It can hold more then one
+     certificate/key and each certificate/key must have unique label within one file.}
+    property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
+  end;
+
+implementation
+
+{==============================================================================}
+
+constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  FPrivateKeyLabel := 'synapse';
+  FDelCert := false;
+end;
+
+destructor TSSLCryptLib.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
+begin
+  inherited Assign(Value);
+  if Value is TSSLCryptLib then
+  begin
+    FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
+  end;
+end;
+
+function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
+var
+  l: integer;
+begin
+  l := 0;
+  cryptGetAttributeString(cryptHandle, attributeType, nil, l);
+  setlength(Result, l);
+  cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
+  setlength(Result, l);
+end;
+
+function TSSLCryptLib.LibVersion: String;
+var
+  x: integer;
+begin
+  Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
+  Result := Result + ' v' + IntToStr(x);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
+  Result := Result + '.' + IntToStr(x);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
+  Result := Result + '.' + IntToStr(x);
+end;
+
+function TSSLCryptLib.LibName: String;
+begin
+  Result := 'ssl_cryptlib';
+end;
+
+function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  FLastError := Value;
+  if FLastError <> 0 then
+  begin
+    Result := False;
+    FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
+  end;
+end;
+
+function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
+var
+  privateKey: CRYPT_CONTEXT;
+  keyset: CRYPT_KEYSET;
+  cert: CRYPT_CERTIFICATE;
+  publicKey: CRYPT_CONTEXT;
+begin
+  Result := False;
+  if FPrivatekeyFile = '' then
+    FPrivatekeyFile := GetTempFile('', 'key');
+  cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
+  cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
+    Length(FPrivatekeyLabel));
+  cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
+  cryptGenerateKey(privateKey);
+  cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
+  FDelCert := True;
+  cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
+  cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
+  cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
+  cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
+  cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
+  cryptSignCert(cert, privateKey);
+  cryptAddPublicKey(keyset, cert);
+  cryptKeysetClose(keyset);
+  cryptDestroyCert(cert);
+  cryptDestroyContext(privateKey);
+  cryptDestroyContext(publicKey);
+  Result := True;
+end;
+
+function TSSLCryptLib.Init(server:Boolean): Boolean;
+var
+  st: CRYPT_SESSION_TYPE;
+  keysetobj: CRYPT_KEYSET;
+  cryptContext: CRYPT_CONTEXT;
+  x: integer;
+begin
+  Result := False;
+  FLastErrorDesc := '';
+  FLastError := 0;
+  FDelCert := false;
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  if server then
+    case FSSLType of
+      LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
+        st := CRYPT_SESSION_SSL_SERVER;
+      LT_SSHv2:
+        st := CRYPT_SESSION_SSH_SERVER;
+    else
+      Exit;
+    end
+  else
+    case FSSLType of
+      LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
+        st := CRYPT_SESSION_SSL;
+      LT_SSHv2:
+        st := CRYPT_SESSION_SSH;
+    else
+      Exit;
+    end;
+  if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
+    Exit;
+  x := -1;
+  case FSSLType of
+    LT_SSLv3:
+      x := 0;
+    LT_TLSv1:
+      x := 1;
+    LT_TLSv1_1:
+      x := 2;
+  end;
+  if x >= 0 then
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
+      Exit;
+  if FUsername <> '' then
+  begin
+    cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
+      Pointer(FUsername), Length(FUsername));
+    cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
+      Pointer(FPassword), Length(FPassword));
+  end;
+  if FSSLType = LT_SSHv2 then
+    if FSSHChannelType <> '' then
+    begin
+      cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
+      cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
+        Pointer(FSSHChannelType), Length(FSSHChannelType));
+      if FSSHChannelArg1 <> '' then
+        cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
+          Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
+      if FSSHChannelArg2 <> '' then
+        cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
+          Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
+    end;
+
+
+  if server and (FPrivatekeyFile = '') then
+  begin
+    if FPrivatekeyLabel = '' then
+      FPrivatekeyLabel := 'synapse';
+    if FkeyPassword = '' then
+      FkeyPassword := 'synapse';
+    CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
+  end;
+
+  if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
+  begin
+    if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
+      PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
+      Exit;
+    try
+    if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
+      PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
+      cryptcontext)) then
+      Exit;
+    finally
+      cryptKeysetClose(keySetObj);
+      cryptDestroyContext(cryptcontext);
+    end;
+  end;
+  if server and FVerifyCert then
+  begin
+    if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
+      PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
+      Exit;
+    try
+    if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
+      keySetObj)) then
+      Exit;
+    finally
+      cryptKeysetClose(keySetObj);
+    end;
+  end;
+  Result := true;
+end;
+
+function TSSLCryptLib.DeInit: Boolean;
+begin
+  Result := True;
+  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    CryptDestroySession(FcryptSession);
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  FSSLEnabled := False;
+  if FDelCert then
+    Deletefile(FPrivatekeyFile);
+end;
+
+function TSSLCryptLib.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLCryptLib.Connect: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(false) then
+  begin
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLCryptLib.Accept: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(true) then
+  begin
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLCryptLib.Shutdown: boolean;
+begin
+  Result := BiShutdown;
+end;
+
+function TSSLCryptLib.BiShutdown: boolean;
+begin
+  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
+  DeInit;
+  Result := True;
+end;
+
+function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
+  cryptFlushData(FcryptSession);
+  Result := l;
+end;
+
+function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  SSLCheck(cryptPopData(FCryptSession, Buffer, Len, L));
+  Result := l;
+end;
+
+function TSSLCryptLib.WaitingData: Integer;
+begin
+  Result := 0;
+end;
+
+function TSSLCryptLib.GetSSLVersion: string;
+var
+  x: integer;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
+  if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
+    case x of
+      0:
+        Result := 'SSLv3';
+      1:
+        Result := 'TLSv1';
+      2:
+        Result := 'TLSv1.1';
+    end;
+  if FSSLType in [LT_SSHv2] then
+    case x of
+      0:
+        Result := 'SSHv1';
+      1:
+        Result := 'SSHv2';
+    end;
+end;
+
+function TSSLCryptLib.GetPeerSubject: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED);
+  Result := GetString(cert, CRYPT_CERTINFO_DN);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerName: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
+  Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerIssuer: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
+  Result := GetString(cert, CRYPT_CERTINFO_DN);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerFingerprint: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
+  Result := MD5(Result);
+  cryptDestroyCert(cert);
+end;
+
+{==============================================================================}
+
+initialization
+  if cryptInit = CRYPT_OK then
+    SSLImplementation := TSSLCryptLib;
+  cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
+
+finalization
+  cryptEnd;
+
+end.
+

ssl_openssl.pas

@@ -0,0 +1,796 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.003 |
+|==============================================================================|
+| Content: SSL support by OpenSSL                                              |
+|==============================================================================|
+| 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):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+//requires OpenSSL libraries!
+
+{:@abstract(SSL plugin for OpenSSL)
+
+You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but
+application mysteriously crashing when you are using freePascal on Linux.
+Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see
+any problems with FreePascal.
+
+OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you
+compile your application with this unit. SSL just not working when you not have
+OpenSSL libraries.
+
+This plugin have limited support for .NET too! Because is not possible to use
+callbacks with CDECL calling convention under .NET, is not supported
+key/certificate passwords and multithread locking. :-(
+
+For handling keys and certificates you can use this properties:
+
+@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br
+@link(TCustomSSL.Certificate) for ASN1 DER format only. @br
+@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br
+@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br
+@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br
+@link(TCustomSSL.PFXFile) for PFX format. @br
+@link(TCustomSSL.PFX) for PFX format from binary string. @br
+
+This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
+server without explicitly assigned key and certificate, then this plugin create
+Ad-Hoc key and certificate for each incomming connection by self. It slowdown
+accepting of new connections!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_openssl;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synsock, synautil,
+{$IFDEF CIL}
+  System.Text,
+{$ENDIF}
+  ssl_openssl_lib;
+
+type
+  {:@abstract(class implementing OpenSSL 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!}
+  TSSLOpenSSL = class(TCustomSSL)
+  protected
+    FSsl: PSSL;
+    Fctx: PSSL_CTX;
+    function SSLCheck: Boolean;
+    function SetSslKeys: boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    function LoadPFX(pfxdata: string): Boolean;
+    function CreateSelfSignedCert(Host: string): Boolean; override;
+  public
+    {:See @inherited}
+    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_cryptlib) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_cryptlib) 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;
+    {:See @inherited}
+    function GetCipherName: string; override;
+    {:See @inherited}
+    function GetCipherBits: integer; override;
+    {:See @inherited}
+    function GetCipherAlgBits: integer; override;
+    {:See @inherited}
+    function GetVerifyCert: integer; override;
+  end;
+
+implementation
+
+{==============================================================================}
+
+{$IFNDEF CIL}
+function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
+var
+  Password: String;
+begin
+  Password := '';
+  if TCustomSSL(userdata) is TCustomSSL then
+    Password := TCustomSSL(userdata).KeyPassword;
+  if Length(Password) > (Size - 1) then
+    SetLength(Password, Size - 1);
+  Result := Length(Password);
+  StrLCopy(buf, PChar(Password + #0), Result + 1);
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FCiphers := 'DEFAULT';
+  FSsl := nil;
+  Fctx := nil;
+end;
+
+destructor TSSLOpenSSL.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+function TSSLOpenSSL.LibVersion: String;
+begin
+  Result := SSLeayversion(0);
+end;
+
+function TSSLOpenSSL.LibName: String;
+begin
+  Result := 'ssl_openssl';
+end;
+
+function TSSLOpenSSL.SSLCheck: Boolean;
+{$IFDEF CIL}
+var
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  FLastError := ErrGetError;
+  ErrClearError;
+  if FLastError <> 0 then
+  begin
+    Result := False;
+{$IFDEF CIL}
+    sb := StringBuilder.Create(256);
+    ErrErrorString(FLastError, sb, 256);
+    FLastErrorDesc := Trim(sb.ToString);
+{$ELSE}
+    FLastErrorDesc := StringOfChar(#0, 256);
+    ErrErrorString(FLastError, FLastErrorDesc, Length(FLastErrorDesc));
+{$ENDIF}
+  end;
+end;
+
+function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean;
+var
+  pk: EVP_PKEY;
+  x: PX509;
+  rsa: PRSA;
+  t: PASN1_UTCTIME;
+  name: PX509_NAME;
+  b: PBIO;
+  xn, y: integer;
+  s: AnsiString;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  Result := True;
+  pk := EvpPkeynew;
+  x := X509New;
+  try
+    rsa := RsaGenerateKey(1024, $10001, nil, nil);
+    EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
+    X509SetVersion(x, 2);
+    Asn1IntegerSet(X509getSerialNumber(x), 0);
+    t := Asn1UtctimeNew;
+    try
+      X509GmtimeAdj(t, -60 * 60 *24);
+      X509SetNotBefore(x, t);
+      X509GmtimeAdj(t, 60 * 60 * 60 *24);
+      X509SetNotAfter(x, t);
+    finally
+      Asn1UtctimeFree(t);
+    end;
+    X509SetPubkey(x, pk);
+    Name := X509GetSubjectName(x);
+    X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0);
+    X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0);
+    x509SetIssuerName(x, Name);
+    x509Sign(x, pk, EvpGetDigestByName('SHA1'));
+    b := BioNew(BioSMem);
+    try
+      i2dX509Bio(b, x);
+      xn := bioctrlpending(b);
+{$IFDEF CIL}
+      sb := StringBuilder.Create(xn);
+      y := bioread(b, sb, xn);
+      if y > 0 then
+      begin
+        sb.Length := y;
+        s := sb.ToString;
+      end;
+{$ELSE}
+      setlength(s, xn);
+      y := bioread(b, s, xn);
+      if y > 0 then
+        setlength(s, y);
+{$ENDIF}
+    finally
+      BioFreeAll(b);
+    end;
+    FCertificate := s;
+    b := BioNew(BioSMem);
+    try
+      i2dPrivatekeyBio(b, pk);
+      xn := bioctrlpending(b);
+{$IFDEF CIL}
+      sb := StringBuilder.Create(xn);
+      y := bioread(b, sb, xn);
+      if y > 0 then
+      begin
+        sb.Length := y;
+        s := sb.ToString;
+      end;
+{$ELSE}
+      setlength(s, xn);
+      y := bioread(b, s, xn);
+      if y > 0 then
+        setlength(s, y);
+{$ENDIF}
+    finally
+      BioFreeAll(b);
+    end;
+    FPrivatekey := s;
+  finally
+    X509free(x);
+    EvpPkeyFree(pk);
+  end;
+end;
+
+function TSSLOpenSSL.LoadPFX(pfxdata: string): Boolean;
+var
+  cert, pkey, ca: SslPtr;
+  b: PBIO;
+  p12: SslPtr;
+begin
+  Result := False;
+  b := BioNew(BioSMem);
+  try
+    BioWrite(b, pfxdata, Length(PfxData));
+    p12 := d2iPKCS12bio(b, nil);
+    if not Assigned(p12) then
+      Exit;
+    try
+      cert := nil;
+      pkey := nil;
+      ca := nil;
+      if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
+        if SSLCTXusecertificate(Fctx, cert) > 0 then
+          if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
+            Result := True;
+    finally
+      PKCS12free(p12);
+    end;
+  finally
+    BioFreeAll(b);
+  end;
+end;
+
+function TSSLOpenSSL.SetSslKeys: boolean;
+var
+  st: TFileStream;
+  s: string;
+begin
+  Result := False;
+  if not assigned(FCtx) then
+    Exit;
+  try
+    if FCertificateFile <> '' then
+      if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then
+        if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then
+          if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then
+            Exit;
+    if FCertificate <> '' then
+      if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then
+        Exit;
+    SSLCheck;
+    if FPrivateKeyFile <> '' then
+      if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then
+        if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then
+          Exit;
+    if FPrivateKey <> '' then
+      if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then
+        Exit;
+    SSLCheck;
+    if FCertCAFile <> '' then
+      if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then
+        Exit;
+    if FPFXfile <> '' then
+    begin
+      try
+        st := TFileStream.Create(FPFXfile, fmOpenRead	 or fmShareDenyNone);
+        try
+          s := ReadStrFromStream(st, st.Size);
+        finally
+          st.Free;
+        end;
+        if not LoadPFX(s) then
+          Exit;
+      except
+        on Exception do
+          Exit;
+      end;
+    end;
+    if FPFX <> '' then
+      if not LoadPFX(FPfx) then
+        Exit;
+    SSLCheck;
+    Result := True;
+  finally
+    SSLCheck;
+  end;
+end;
+
+function TSSLOpenSSL.Init(server:Boolean): Boolean;
+begin
+  Result := False;
+  FLastErrorDesc := '';
+  FLastError := 0;
+  Fctx := nil;
+  case FSSLType of
+    LT_SSLv2:
+      Fctx := SslCtxNew(SslMethodV2);
+    LT_SSLv3:
+      Fctx := SslCtxNew(SslMethodV3);
+    LT_TLSv1:
+      Fctx := SslCtxNew(SslMethodTLSV1);
+    LT_all:
+      Fctx := SslCtxNew(SslMethodV23);
+  else
+    Exit;
+  end;
+  if Fctx = nil then
+  begin
+    SSLCheck;
+    Exit;
+  end
+  else
+  begin
+    SslCtxSetCipherList(Fctx, FCiphers);
+    if FVerifyCert then
+      SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
+    else
+      SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
+{$IFNDEF CIL}
+    SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
+    SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
+{$ENDIF}
+
+    if server and (FCertificateFile = '') and (FCertificate = '')
+      and (FPFXfile = '') and (FPFX = '') then
+    begin
+      CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
+    end;
+
+    if not SetSSLKeys then
+      Exit
+    else
+    begin
+      Fssl := nil;
+      Fssl := SslNew(Fctx);
+      if Fssl = nil then
+      begin
+        SSLCheck;
+        exit;
+      end;
+    end;
+  end;
+  Result := true;
+end;
+
+function TSSLOpenSSL.DeInit: Boolean;
+begin
+  Result := True;
+  if assigned (Fssl) then
+    sslfree(Fssl);
+  Fssl := nil;
+  if assigned (Fctx) then
+  begin
+    SslCtxFree(Fctx);
+    Fctx := nil;
+    ErrRemoveState(0);
+  end;
+  FSSLEnabled := False;
+end;
+
+function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLOpenSSL.Connect: boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(False) then
+  begin
+{$IFDEF CIL}
+    if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
+{$ELSE}
+    if sslsetfd(FSsl, FSocket.Socket) < 1 then
+{$ENDIF}
+    begin
+      SSLCheck;
+      Exit;
+    end;
+    x := sslconnect(FSsl);
+    if x < 1 then
+    begin
+      SSLcheck;
+      Exit;
+    end;
+  if FverifyCert then
+    if GetVerifyCert <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLOpenSSL.Accept: boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(True) then
+  begin
+{$IFDEF CIL}
+    if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
+{$ELSE}
+    if sslsetfd(FSsl, FSocket.Socket) < 1 then
+{$ENDIF}
+    begin
+      SSLCheck;
+      Exit;
+    end;
+    x := sslAccept(FSsl);
+    if x < 1 then
+    begin
+      SSLcheck;
+      Exit;
+    end;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLOpenSSL.Shutdown: boolean;
+begin
+  if assigned(FSsl) then
+    sslshutdown(FSsl);
+  DeInit;
+  Result := True;
+end;
+
+function TSSLOpenSSL.BiShutdown: boolean;
+var
+  x: integer;
+begin
+  if assigned(FSsl) then
+  begin
+    x := sslshutdown(FSsl);
+    if x = 0 then
+    begin
+      Synsock.Shutdown(FSocket.Socket, 1);
+      sslshutdown(FSsl);
+    end;
+  end;
+  DeInit;
+  Result := True;
+end;
+
+function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  err: integer;
+{$IFDEF CIL}
+  s: ansistring;
+{$ENDIF}
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  repeat
+{$IFDEF CIL}
+    s := StringOf(Buffer);
+    Result := SslWrite(FSsl, s, Len);
+{$ELSE}
+    Result := SslWrite(FSsl, Buffer , Len);
+{$ENDIF}
+    err := SslGetError(FSsl, Result);
+  until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
+  if err = SSL_ERROR_ZERO_RETURN then
+    Result := 0
+  else
+    if (err <> 0) then
+      FLastError := err;
+end;
+
+function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  err: integer;
+{$IFDEF CIL}
+  sb: stringbuilder;
+  s: ansistring;
+{$ENDIF}
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  repeat
+{$IFDEF CIL}
+    sb := StringBuilder.Create(Len);
+    Result := SslRead(FSsl, sb, Len);
+    if Result > 0 then
+    begin
+      sb.Length := Result;
+      s := sb.ToString;
+      System.Array.Copy(BytesOf(s), Buffer, length(s));
+    end;
+{$ELSE}
+    Result := SslRead(FSsl, Buffer , Len);
+{$ENDIF}
+    err := SslGetError(FSsl, Result);
+  until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
+  if err = SSL_ERROR_ZERO_RETURN then
+    Result := 0
+  else
+    if (err <> 0) then
+      FLastError := err;
+end;
+
+function TSSLOpenSSL.WaitingData: Integer;
+begin
+  Result := sslpending(Fssl);
+end;
+
+function TSSLOpenSSL.GetSSLVersion: string;
+begin
+  if not assigned(FSsl) then
+    Result := ''
+  else
+    Result := SSlGetVersion(FSsl);
+end;
+
+function TSSLOpenSSL.GetPeerSubject: string;
+var
+  cert: PX509;
+  s: string;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+{$IFDEF CIL}
+  sb := StringBuilder.Create(4096);
+  Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096);
+{$ELSE}
+  setlength(s, 4096);
+  Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s));
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetPeerName: string;
+var
+  s: string;
+begin
+  s := GetPeerSubject;
+  s := SeparateRight(s, '/CN=');
+  Result := Trim(SeparateLeft(s, '/'));
+end;
+
+function TSSLOpenSSL.GetPeerIssuer: string;
+var
+  cert: PX509;
+  s: string;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+{$IFDEF CIL}
+  sb := StringBuilder.Create(4096);
+  Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096);
+{$ELSE}
+  setlength(s, 4096);
+  Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s));
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetPeerFingerprint: string;
+var
+  cert: PX509;
+  x: integer;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+{$IFDEF CIL}
+  sb := StringBuilder.Create(EVP_MAX_MD_SIZE);
+  X509Digest(cert, EvpGetDigestByName('MD5'), sb, x);
+  sb.Length := x;
+  Result := sb.ToString;
+{$ELSE}
+  setlength(Result, EVP_MAX_MD_SIZE);
+  X509Digest(cert, EvpGetDigestByName('MD5'), Result, x);
+  SetLength(Result, x);
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetCertInfo: string;
+var
+  cert: PX509;
+  x, y: integer;
+  b: PBIO;
+  s: AnsiString;
+{$IFDEF CIL}
+  sb: stringbuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  b := BioNew(BioSMem);
+  try
+    X509Print(b, cert);
+    x := bioctrlpending(b);
+{$IFDEF CIL}
+    sb := StringBuilder.Create(x);
+    y := bioread(b, sb, x);
+    if y > 0 then
+    begin
+      sb.Length := y;
+      s := sb.ToString;
+    end;
+{$ELSE}
+    setlength(s,x);
+    y := bioread(b,s,x);
+    if y > 0 then
+      setlength(s, y);
+{$ENDIF}
+    Result := ReplaceString(s, LF, CRLF);
+  finally
+    BioFreeAll(b);
+  end;
+end;
+
+function TSSLOpenSSL.GetCipherName: string;
+begin
+  if not assigned(FSsl) then
+    Result := ''
+  else
+    Result := SslCipherGetName(SslGetCurrentCipher(FSsl));
+end;
+
+function TSSLOpenSSL.GetCipherBits: integer;
+var
+  x: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 0
+  else
+    Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x);
+end;
+
+function TSSLOpenSSL.GetCipherAlgBits: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 0
+  else
+    SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result);
+end;
+
+function TSSLOpenSSL.GetVerifyCert: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 1
+  else
+    Result := SslGetVerifyResult(FSsl);
+end;
+
+{==============================================================================}
+
+initialization
+  if InitSSLInterface then
+    SSLImplementation := TSSLOpenSSL;
+
+end.

ssl_streamsec.pas

@@ -0,0 +1,528 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.005 |
+|==============================================================================|
+| Content: SSL support by StreamSecII                                          |
+|==============================================================================|
+| 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):                                                              |
+|   Henrick Hellström <henrick@streamsec.se>                                   |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
+
+StreamSecII is native pascal library, you not need any external libraries!
+
+You can tune lot of StreamSecII properties by using your GlobalServer. If you not
+using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
+instance for each TCP connection. Formore information about GlobalServer usage
+refer StreamSecII documentation.
+
+If you are not using key and certificate by GlobalServer, then you can use
+properties of this plugin instead, but this have limited features and
+@link(TCustomSSL.KeyPassword) not working properly yet!
+
+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 StreamSecII documentation.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_streamsec;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synsock, synautil, synacode,
+  TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
+  SecUtils;
+
+type
+  {:@exclude}
+  TMyTLSSynSockSlave = class(TTLSSynSockSlave)
+  protected
+    procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
+    function GetMyTLSServer: TCustomTLSInternalServer;
+  published
+    property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer;
+  end;
+
+  {:@abstract(class implementing StreamSecII 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!}
+  TSSLStreamSec = class(TCustomSSL)
+  protected
+    FSlave: TMyTLSSynSockSlave;
+    FIsServer: Boolean;
+    FTLSServer: TCustomTLSInternalServer;
+    function SSLCheck: Boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
+    function X500StrToStr(const Prefix: string; const Value: TX500String): string;
+    function X501NameToStr(const Value: TX501Name): string;
+    function GetCert: PASN1Struct;
+  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_streamsec) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_streamsec) 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
+    {:TLS server for tuning of StreamSecII.}
+    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
+  end;
+
+implementation
+
+{==============================================================================}
+procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
+begin
+  TLSServer := Value;
+end;
+
+function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
+begin
+  Result := TLSServer;
+end;
+
+{==============================================================================}
+
+constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FSlave := nil;
+  FIsServer := False;
+  FTLSServer := nil;
+end;
+
+destructor TSSLStreamSec.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+function TSSLStreamSec.LibVersion: String;
+begin
+  Result := 'StreamSecII';
+end;
+
+function TSSLStreamSec.LibName: String;
+begin
+  Result := 'ssl_streamsec';
+end;
+
+function TSSLStreamSec.SSLCheck: Boolean;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  if not Assigned(FSlave) then
+    Exit;
+  FLastError := FSlave.ErrorCode;
+  if FLastError <> 0 then
+  begin
+    FLastErrorDesc := TlsConst.AlertMsg(FLastError);
+  end;
+end;
+
+procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
+begin
+  ExplicitTrust := true;
+end;
+
+function TSSLStreamSec.Init(server:Boolean): Boolean;
+var
+  st: TMemoryStream;
+  pass: TSecretKey;
+  ws: WideString;
+begin
+  Result := False;
+  ws := FKeyPassword;
+  pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
+  try
+    FIsServer := Server;
+    FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
+    if Assigned(FTLSServer) then
+      FSlave.MyTLSServer := FTLSServer
+    else
+      if Assigned(TLSInternalServer.GlobalServer) then
+        FSlave.MyTLSServer := TLSInternalServer.GlobalServer
+      else
+        FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
+    if server then
+      FSlave.MyTLSServer.ClientOrServer := cosServerSide
+    else
+      FSlave.MyTLSServer.ClientOrServer := cosClientSide;
+    if not FVerifyCert then
+    begin
+      FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
+    end;
+    FSlave.MyTLSServer.Options.VerifyServerName := [];
+    FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
+    FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
+    FSlave.MyTLSServer.Options.RequestClientCertificate := False;
+    FSlave.MyTLSServer.Options.RequireClientCertificate := False;
+    if server and FVerifyCert then
+    begin
+      FSlave.MyTLSServer.Options.RequestClientCertificate := True;
+      FSlave.MyTLSServer.Options.RequireClientCertificate := True;
+    end;
+    if FCertCAFile <> '' then
+      FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
+    if FCertCA <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FCertCA);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadRootCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FTrustCertificateFile <> '' then
+      FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
+    if FTrustCertificate <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FTrustCertificate);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FPrivateKeyFile <> '' then
+      FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
+//      FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
+    if FPrivateKey <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FPrivateKey);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
+      finally
+        st.free;
+      end;
+    end;
+    if FCertificateFile <> '' then
+      FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
+    if FCertificate <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FCertificate);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadMyCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FPFXfile <> '' then
+      FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
+    if server then
+    begin
+      FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
+      FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
+      FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
+      FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
+      FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
+      FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
+      FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
+      FSlave.MyTLSServer.TLSSetupServer;
+    end;
+    Result := true;
+  finally
+    pass.Free;
+  end;
+end;
+
+function TSSLStreamSec.DeInit: Boolean;
+begin
+  Result := True;
+  if assigned(FSlave) then
+  begin
+    FSlave.Close;
+    FSlave.Free;
+    FSlave := nil;
+  end;
+  FSSLEnabled := false;
+end;
+
+function TSSLStreamSec.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLStreamSec.Connect: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(false) then
+  begin
+    FSlave.Open;
+    SSLCheck;
+    if FLastError <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLStreamSec.Accept: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(true) then
+  begin
+    FSlave.Open;
+    SSLCheck;
+    if FLastError <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLStreamSec.Shutdown: boolean;
+begin
+  Result := BiShutdown;
+end;
+
+function TSSLStreamSec.BiShutdown: boolean;
+begin
+  DeInit;
+  Result := True;
+end;
+
+function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  l := len;
+  FSlave.SendBuf(Buffer^, l, true);
+  Result := l;
+  SSLCheck;
+end;
+
+function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  l := Len;
+  Result := FSlave.ReceiveBuf(Buffer^, l);
+  SSLCheck;
+end;
+
+function TSSLStreamSec.WaitingData: Integer;
+begin
+  Result := 0;
+  while FSlave.Connected do begin
+    Result := FSlave.ReceiveLength;
+    if Result > 0 then
+      Break;
+    Sleep(1);
+  end;
+end;
+
+function TSSLStreamSec.GetSSLVersion: string;
+begin
+  Result := 'SSLv3 or TLSv1';
+end;
+
+function TSSLStreamSec.GetCert: PASN1Struct;
+begin
+  if FIsServer then
+    Result := FSlave.GetClientCert
+  else
+    Result := FSlave.GetServerCert;
+end;
+
+function TSSLStreamSec.GetPeerSubject: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractSubject(Cert^,XName, false);
+    Result := X501NameToStr(XName);
+  end;
+end;
+
+function TSSLStreamSec.GetPeerName: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractSubject(Cert^,XName, false);
+    Result := XName.commonName.Str;
+  end;
+end;
+
+function TSSLStreamSec.GetPeerIssuer: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractIssuer(Cert^, XName, false);
+    Result := X501NameToStr(XName);
+  end;
+end;
+
+function TSSLStreamSec.GetPeerFingerprint: string;
+var
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+    Result := MD5(Cert.ContentAsOctetString);
+end;
+
+function TSSLStreamSec.GetCertInfo: string;
+var
+  Cert: PASN1Struct;
+  l: Tstringlist;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    l := TStringList.Create;
+    try
+      Asn1.RenderAsText(cert^, l, true, true, true, 2);
+      Result := l.Text;
+    finally
+      l.free;
+    end;
+  end;
+end;
+
+function TSSLStreamSec.X500StrToStr(const Prefix: string;
+  const Value: TX500String): string;
+begin
+  if Value.Str = '' then
+    Result := ''
+  else
+    Result := '/' + Prefix + '=' + Value.Str;
+end;
+
+function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
+begin
+  Result := X500StrToStr('CN',Value.commonName) +
+           X500StrToStr('C',Value.countryName) +
+           X500StrToStr('L',Value.localityName) +
+           X500StrToStr('ST',Value.stateOrProvinceName) +
+           X500StrToStr('O',Value.organizationName) +
+           X500StrToStr('OU',Value.organizationalUnitName) +
+           X500StrToStr('T',Value.title) +
+           X500StrToStr('N',Value.name) +
+           X500StrToStr('G',Value.givenName) +
+           X500StrToStr('I',Value.initials) +
+           X500StrToStr('SN',Value.surname) +
+           X500StrToStr('GQ',Value.generationQualifier) +
+           X500StrToStr('DNQ',Value.dnQualifier) +
+           X500StrToStr('E',Value.emailAddress);
+end;
+
+
+{==============================================================================}
+
+initialization
+  SSLImplementation := TSSLStreamSec;
+
+finalization
+
+end.
+

sslinux.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.000.003 |
+| Project : Ararat Synapse                                       | 002.000.005 |
 |==============================================================================|
 | Content: Socket Independent Platform Layer - Linux definition include        |
 |==============================================================================|
@@ -204,7 +204,8 @@ type
     padding: u_long;
   end;
 
-  hostent = record
+  PHostEnt = ^THostEnt;
+  THostent = record
     h_name: PChar;
     h_aliases: PPChar;
     h_addrtype: Integer;
@@ -738,7 +739,7 @@ end;
 
 function __FDMASK(Socket: TSocket): __fd_mask;
 begin
-  Result := 1 shl (Socket mod __NFDBITS);
+  Result := LongWord(1) shl (Socket mod __NFDBITS);
 end;
 
 function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;

synachar.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 005.001.000 |
+| Project : Ararat Synapse                                       | 005.001.003 |
 |==============================================================================|
 | Content: Charset conversion support                                          |
 |==============================================================================|
@@ -64,6 +64,15 @@ unit synachar;
 
 interface
 
+uses
+{$IFDEF LINUX}
+  Libc,
+{$ELSE}
+  Windows,
+{$ENDIF}
+  SysUtils,
+  synautil, synacode, synaicnv;
+
 type
   {:Type with all supported charsets.}
   TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
@@ -193,16 +202,6 @@ function WideToString(const Value: WideString): AnsiString;
 {==============================================================================}
 implementation
 
-uses
-{$IFDEF LINUX}
-  Libc,
-{$ELSE}
-  Windows,
-{$ENDIF}
-  SysUtils,
-  synautil, synacode, synaicnv;
-
-
 //character transcoding tables X to UCS-2
 {
 //dummy table
@@ -996,9 +995,9 @@ Begin
             b1 := Ord(Value[Index + 3]);
           End;
       end;
-    Inc(Index, mb);
+  end;
-  End;
+  Inc(Index, mb);
-End;
+end;
 
 {==============================================================================}
 function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString;
@@ -1279,6 +1278,61 @@ begin
 end;
 
 {==============================================================================}
+
+function InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString;
+var
+  uni: Word;
+  n: Integer;
+  b1, b2, b3, b4: Byte;
+  SourceTable: array[128..255] of Word;
+  mbf: Byte;
+  lef: Boolean;
+  s: AnsiString;
+begin
+  if CharFrom = UTF_8 then
+    s := UTF8toUCS4(Value)
+  else
+    if CharFrom = UTF_7 then
+      s := UTF7toUCS2(Value, False)
+    else
+      if CharFrom = UTF_7mod then
+        s := UTF7toUCS2(Value, True)
+      else
+        s := Value;
+  GetArray(CharFrom, SourceTable);
+  mbf := 1;
+  if CharFrom in SetTwo then
+    mbf := 2;
+  if CharFrom in SetFour then
+    mbf := 4;
+  lef := CharFrom in SetLe;
+  Result := '';
+  n := 1;
+  while Length(s) >= n do
+  begin
+    ReadMulti(s, n, mbf, b1, b2, b3, b4, lef);
+    //handle BOM
+    if (b3 = 0) and (b4 = 0) then
+    begin
+      if (b1 = $FE) and (b2 = $FF) then
+      begin
+        lef := not lef;
+        continue;
+      end;
+      if (b1 = $FF) and (b2 = $FE) then
+        continue;
+    end;
+    if mbf = 1 then
+      if b1 > 127 then
+      begin
+        uni := SourceTable[b1];
+        b1 := Lo(uni);
+        b2 := Hi(uni);
+      end;
+    Result := Result + WriteMulti(b1, b2, b3, b4, 2, False);
+  end;
+end;
+
 function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar;
   CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString;
 var
@@ -1286,9 +1340,9 @@ var
   n, m: Integer;
   b: Byte;
   b1, b2, b3, b4: Byte;
-  SourceTable, TargetTable: array[128..255] of Word;
+  TargetTable: array[128..255] of Word;
-  mbf, mbt: Byte;
+  mbt: Byte;
-  lef, let: Boolean;
+  let: Boolean;
   ucsstring, s, t: AnsiString;
   cd: iconv_t;
   f: Boolean;
@@ -1305,62 +1359,15 @@ begin
   ToID := GetIDFromCP(CharTo);
   cd := Iconv_t(-1);
   //do two-pass conversion. Transform to UCS-2 first.
-  if CharFrom = UCS_2 then
+  if not DisableIconv then
-    ucsstring := Value
+    cd := SynaIconvOpenIgnore('UCS-2BE', FromID);
-  else
+  try
-  begin
+    if cd <> iconv_t(-1) then
-    if not DisableIconv then
+      SynaIconv(cd, Value, ucsstring)
-      cd := SynaIconvOpenIgnore('UCS-2BE', FromID);
+    else
-    try
+      ucsstring := InternalToUcs(Value, CharFrom);
-      if cd <> iconv_t(-1) then
+  finally
-        SynaIconv(cd, Value, ucsstring)
+    SynaIconvClose(cd);
-      else
-      begin
-        s := Value;
-        if CharFrom = UTF_8 then
-          s := UTF8toUCS4(Value)
-        else
-          if CharFrom = UTF_7 then
-            s := UTF7toUCS2(Value, False)
-          else
-            if CharFrom = UTF_7mod then
-              s := UTF7toUCS2(Value, True);
-        GetArray(CharFrom, SourceTable);
-        mbf := 1;
-        if CharFrom in SetTwo then
-          mbf := 2;
-        if CharFrom in SetFour then
-          mbf := 4;
-        lef := CharFrom in SetLe;
-        ucsstring := '';
-        n := 1;
-        while Length(s) >= n do
-        begin
-          ReadMulti(s, n, mbf, b1, b2, b3, b4, lef);
-          //handle BOM
-          if (b3 = 0) and (b4 = 0) then
-          begin
-            if (b1 = $FE) and (b2 = $FF) then
-            begin
-              lef := not lef;
-              continue;
-            end;
-            if (b1 = $FF) and (b2 = $FE) then
-              continue;
-          end;
-          if mbf = 1 then
-            if b1 > 127 then
-            begin
-              uni := SourceTable[b1];
-              b1 := Lo(uni);
-              b2 := Hi(uni);
-            end;
-          ucsstring := ucsstring + WriteMulti(b1, b2, b3, b4, 2, False);
-        end;
-      end;
-    finally
-      SynaIconvClose(cd);
-    end;
   end;
   //here we allways have ucstring with UCS-2 encoding
   //second pass... from UCS-2 to target encoding.

synacode.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.001.003 |
+| Project : Ararat Synapse                                       | 002.001.004 |
 |==============================================================================|
 | Content: Coding and decoding support                                         |
 |==============================================================================|
@@ -68,7 +68,7 @@ const
   NonAsciiChar: TSpecials =
   [Char(0)..Char(31), Char(127)..Char(255)];
   URLFullSpecialChar: TSpecials =
-  [';', '/', '?', ':', '@', '=', '&', '#'];
+  [';', '/', '?', ':', '@', '=', '&', '#', '+'];
   URLSpecialChar: TSpecials =
   [#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']',
     '`', #$7F..#$FF];

synaicnv.pas

@@ -47,7 +47,12 @@
 {$ENDIF}
 {$H+}
 
-{:@exclude}
+{:@abstract(LibIconv support)
+
+This unit is Pascal interface to LibIconv library for charset translations.
+LibIconv is loaded dynamicly on-demand. If this library is not found in system,
+requested LibIconv function just return errorcode.
+}
 unit synaicnv;
 
 interface
@@ -216,8 +221,8 @@ begin
     ix := Length(inbuf);
     ox := Length(Outbuf);
     _iconv(cd, ib, ix, ob, ox);
-    setlength(Outbuf, Length(Outbuf) - ox);
+    setlength(Outbuf, cardinal(Length(Outbuf)) - ox);
-    Result := Length(inbuf) - ix;
+    Result := Cardinal(Length(inbuf)) - ix;
   end
   else
   begin
@@ -335,7 +340,7 @@ begin
   Result := IconvLoaded;
 end;
 
-initialization
+ initialization
 begin
   IconvCS:= TCriticalSection.Create;
 end;

synautil.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 004.006.009 |
+| Project : Ararat Synapse                                       | 004.008.001 |
 |==============================================================================|
 | Content: support procedures and functions                                    |
 |==============================================================================|
@@ -62,6 +62,9 @@ uses
   Libc,
 {$ELSE}
   Windows,
+{$ENDIF}
+{$IFDEF CIL}
+  System.IO,
 {$ENDIF}
   SysUtils, Classes;
 
@@ -280,7 +283,10 @@ function CountOfChar(const Value: string; Chr: char): integer;
 
 {:Remove quotation from Value string. If Value is not quoted, then return same
  string without any modification. }
-function UnquoteStr(Value: string; Quote: Char): string;
+function UnquoteStr(const Value: string; Quote: Char): string;
+
+{:Quote Value string. If Value contains some Quote chars, then it is doubled.}
+function QuoteStr(const Value: string; Quote: Char): string;
 
 {:Convert lines in stringlist from 'name: value' form to 'name=value' form.}
 procedure HeadersToList(const Value: TStrings);
@@ -297,6 +303,10 @@ function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
 {:write string to stream.}
 procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
 
+{:Return filename of new temporary file in Dir (if empty, then default temporary
+ directory is used) and with optional filename prefix.}
+function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
+
 var
   {:can be used for your own months strings for @link(getmonthnumber)}
   CustomMonthNames: array[1..12] of string;
@@ -339,11 +349,12 @@ begin
 {$IFNDEF FPC}
   __time(@T);
   localtime_r(@T, UT);
+  Result := ut.__tm_gmtoff div 60;
 {$ELSE}
   __time(T);
   localtime_r(T, UT);
+  Result := ut.tm_gmtoff div 60;
 {$ENDIF}
-  Result := ut.__tm_gmtoff div 60;
 {$ELSE}
 var
   zoneinfo: TTimeZoneInformation;
@@ -745,7 +756,6 @@ var
   TZ: Ttimezone;
   PZ: PTimeZone;
 begin
-  Result := false;
   TZ.tz_minuteswest := 0;
   TZ.tz_dsttime := 0;
   PZ := @TZ;
@@ -947,13 +957,12 @@ end;
 //Hernan Sanchez
 function IPToID(Host: string): string;
 var
-  s, t: string;
+  s: string;
   i, x: Integer;
 begin
   Result := '';
   for x := 1 to 3 do
   begin
-    t := '';
     s := Fetch(Host, '.');
     i := StrToIntDef(s, 0);
     Result := Result + Chr(i);
@@ -1096,7 +1105,7 @@ begin
   begin
     s := Trim(FetchEx(v, ';', '"'));
     if Pos(Uppercase(parameter), Uppercase(s)) = 1 then
-    begin
+    begin                       
       Delete(s, 1, Length(Parameter));
       s := Trim(s);
       if s = '' then
@@ -1416,13 +1425,11 @@ end;
 
 function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
 var
-  n: integer;
   b: Boolean;
 begin
   Result := '';
   b := False;
-  n := 1;
+  while Length(Value) > 0 do
-  while n <= Length(Value) do
   begin
     if b then
     begin
@@ -1551,26 +1558,57 @@ end;
 {$ENDIF}
 
 {==============================================================================}
-
+//improved by 'DoggyDawg'
 function GetBetween(const PairBegin, PairEnd, Value: string): string;
 var
   n: integer;
   x: integer;
   s: string;
+  lenBegin: integer;
+  lenEnd: integer;
+  str: string;
+  max: integer;
 begin
-  Result := '';
+  lenBegin := Length(PairBegin);
-  s := SeparateRight(Value, PairBegin);
+  lenEnd := Length(PairEnd);
-  x := 1;
+  n := Length(Value);
-  for n := 1 to Length(s) do
+  if (Value = PairBegin + PairEnd) then
   begin
-    if s[n] = PairBegin then
+    Result := '';//nothing between
-      Inc(x);
+    exit;
-    if s[n] = PairEnd then
+  end;
+  if (n < lenBegin + lenEnd) then
+  begin
+    Result := Value;
+    exit;
+  end;
+  s := SeparateRight(Value, PairBegin);
+  if (s = Value) then
+  begin
+    Result := Value;
+    exit;
+  end;
+  n := Pos(PairEnd, s);
+  if (n = 0) then
+  begin
+    Result := Value;
+    exit;
+  end;
+  Result := '';
+  x := 1;
+  max := Length(s) - lenEnd + 1;
+  for n := 1 to max do
+  begin
+    str := copy(s, n, lenEnd);
+    if (str = PairEnd) then
     begin
       Dec(x);
-      if x <= 0 then
+      if (x <= 0) then
         Break;
     end;
+    str := copy(s, n, lenBegin);
+    if (str = PairBegin) then
+      Inc(x);
     Result := Result + s[n];
   end;
 end;
@@ -1588,36 +1626,60 @@ begin
 end;
 
 {==============================================================================}
-
+// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application!
-function UnquoteStr(Value: string; Quote: Char): string;
+function UnquoteStr(const Value: string; Quote: Char): string;
-  {$IFNDEF CIL}
 var
-  LText: PChar;
+  n: integer;
-  {$ENDIF}
+  inq, dq: Boolean;
+  c, cn: char;
 begin
+  Result := '';
   if Value = '' then
-  begin
-    Result := '';
     Exit;
-  end;
   if Value = Quote + Quote then
-  begin
-    Result := '';
     Exit;
+  inq := False;
+  dq := False;
+  for n := 1 to Length(Value) do
+  begin
+    c := Value[n];
+    if n <> Length(Value) then
+      cn := Value[n + 1]
+    else
+      cn := #0;
+    if c = quote then
+      if dq then
+        dq := False
+      else
+        if not inq then
+          inq := True
+        else
+          if cn = quote then
+          begin
+            Result := Result + Quote;
+            dq := True;
+          end
+          else
+            inq := False
+    else
+      Result := Result + c;
   end;
-  //workaround for bug in AnsiExtractQuotedStr
+end;
-  //...if string begin by Quote, but not ending by Quote, then it eat last char.
+
-  if length(Value) > 1 then
+{==============================================================================}
-    if (Value[1] = Quote) and (Value[Length(value)] <> Quote) then
+
-      Value := Value + Quote;
+function QuoteStr(const Value: string; Quote: Char): string;
-  {$IFNDEF CIL}
+var
-  LText := PChar(Value);
+  n: integer;
-  Result := AnsiExtractQuotedStr(LText, Quote);
+begin
-  {$ELSE}
+  Result := '';
-  Result := DequotedStr(Value, Quote);
+  for n := 1 to length(value) do
-  {$ENDIF}
+  begin
-  if Result = '' then
+    Result := result + Value[n];
-    Result := Value;
+    if value[n] = Quote then
+      Result := Result + Quote;
+  end;
+  Result :=  Quote + Result + Quote;
 end;
 
 {==============================================================================}
@@ -1710,6 +1772,45 @@ begin
 {$ENDIF}
 end;
 
+{==============================================================================}
+function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
+{$IFNDEF FPC}
+{$IFNDEF LINUX}
+var
+  Path: AnsiString;
+  x: integer;
+{$ENDIF}
+{$ENDIF}
+begin
+{$IFDEF FPC}
+  Result := GetTempFileName(Dir, Prefix);
+{$ELSE}
+  {$IFDEF LINUX}
+    Result := tempnam(Pointer(Dir), Pointer(prefix));
+  {$ELSE}
+    {$IFDEF CIL}
+  Result := System.IO.Path.GetTempFileName;
+    {$ELSE}
+  if Dir = '' then
+  begin
+    SetLength(Path, MAX_PATH);
+	  x := GetTempPath(Length(Path), PChar(Path));
+  	SetLength(Path, x);
+  end
+  else
+    Path := Dir;
+  x := Length(Path);
+  if Path[x] <> '\' then
+    Path := Path + '\';
+  SetLength(Result, MAX_PATH + 1);
+  GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result));
+  Result := PChar(Result);
+  SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY);
+    {$ENDIF}
+  {$ENDIF}
+{$ENDIF}
+end;
+
 {==============================================================================}
 var
   n: integer;

tlntsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.001.003 |
+| Project : Ararat Synapse                                       | 001.002.000 |
 |==============================================================================|
-| Content: TELNET client                                                       |
+| Content: TELNET and SSH2 client                                              |
 |==============================================================================|
-| Copyright (c)1999-2003, Lukas Gebauer                                        |
+| Copyright (c)1999-2004, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2002-2003.                |
+| Portions created by Lukas Gebauer are Copyright (c)2002-2005.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -62,6 +62,7 @@ uses
 
 const
   cTelnetProtocol = 'telnet';
+  cSSHProtocol = '22';
 
   TLNT_EOR                = #239;
   TLNT_SE                 = #240;
@@ -86,7 +87,7 @@ type
   TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
      tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
 
-  {:@abstract(Class with implementation of Telnet script client.)
+  {:@abstract(Class with implementation of Telnet/SSH script client.)
 
    Note: Are you missing properties for specify server address and port? Look to
    parent @link(TSynaClient) too!}
@@ -109,6 +110,11 @@ type
     {:Connects to Telnet server.}
     function Login: Boolean;
 
+    {:Connects to SSH2 server and login by Username and Password properties.
+
+     You must use some of SSL plugins with SSH support. For exammple CryptLib.}
+    function SSHLogin: Boolean;
+
     {:Logout from telnet server.}
     procedure Logout;
 
@@ -330,6 +336,19 @@ begin
   Result := True;
 end;
 
+function TTelnetSend.SSHLogin: Boolean;
+begin
+  Result := False;
+  if Connect then
+  begin
+    FSock.SSL.SSLType := LT_SSHv2;
+    FSock.SSL.Username := FUsername;
+    FSock.SSL.Password := FPassword;
+    FSock.SSLDoConnect;
+    Result := FSock.LastError = 0;
+  end;
+end;
+
 procedure TTelnetSend.Logout;
 begin
   FSock.CloseSocket;