diff --git a/asn1util.pas b/asn1util.pas index ba92bb1..55d0892 100644 --- a/asn1util.pas +++ b/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; diff --git a/blcksock.pas b/blcksock.pas index 60e8273..ab4f4cb 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 008.003.007 | +| Project : Ararat Synapse | 009.000.007 | |==============================================================================| | Content: Library base | |==============================================================================| -| 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): | @@ -103,11 +103,11 @@ uses ,System.Net.Sockets ,System.Text {$ENDIF} - , synassl; + ; const - SynapseRelease = '35'; + SynapseRelease = '36'; cLocalhost = '127.0.0.1'; cAnyHost = '0.0.0.0'; @@ -185,7 +185,7 @@ type THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason; const Value: string) of object; - {:this procedural type is used for dataFilter hooks.} + {:This procedural type is used for DataFilter hooks.} THookDataFilter = procedure(Sender: TObject; var Value: string) of object; {:This procedural type is used for hook OnCreateSocket. By this hook you can @@ -193,6 +193,10 @@ type options, etc.)} THookCreateSocket = procedure(Sender: TObject) of object; + {:This procedural type is used for monitoring of communication.} + THookMonitor = procedure(Sender: TObject; Writing: Boolean; + const Buffer: TMemory; Len: Integer) of object; + {:Specify family of socket.} TSocketFamily = ( {:Default mode. Socket family is defined by target address for connection. @@ -215,10 +219,12 @@ type {:Specify requested SSL/TLS version for secure connection.} TSSLType = ( + LT_all, LT_SSLv2, LT_SSLv3, LT_TLSv1, - LT_all + LT_TLSv1_1, + LT_SSHv2 ); {:Specify type of socket delayed option.} @@ -244,6 +250,9 @@ type Value: Integer; end; + TCustomSSL = class; + TSSLClass = class of TCustomSSL; + {:@abstract(Basic IP object.) This is parent class for other class with protocol implementations. Do not use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket), @@ -252,8 +261,8 @@ type private FOnStatus: THookSocketStatus; FOnReadFilter: THookDataFilter; - FOnWriteFilter: THookDataFilter; FOnCreateSocket: THookCreateSocket; + FOnMonitor: THookMonitor; FLocalSin: TVarSin; FRemoteSin: TVarSin; FTag: integer; @@ -306,7 +315,7 @@ type function GetSinPort(Sin: TVarSin): Integer; procedure DoStatus(Reason: THookSocketReason; const Value: string); procedure DoReadFilter(Buffer: TMemory; var Len: Integer); - procedure DoWriteFilter(Buffer: TMemory; var Len: Integer); + procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); procedure DoCreateSocket; procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: ULong); procedure SetBandwidth(Value: Integer); @@ -785,13 +794,13 @@ type It is used by telnet client by example.} property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter; - {:This event is good for some internal thinks about filtering writed datas.} - property OnWriteFilter: THookDataFilter read FOnWriteFilter write FOnWriteFilter; - {:This event is called after real socket creation for setting special socket options, because you not know when socket is created. (it is depended on Ipv4, IPv6 or automatic mode)} property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket; + + {:This event is good for monitoring content of readed or writed datas.} + property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor; end; {:@abstract(Support for SOCKS4 and SOCKS5 proxy) @@ -867,24 +876,12 @@ type end; {:@abstract(Implementation of TCP socket.) - Supported features: IPv4, IPv6, SSL/TLS (SSL2, SSL3 and TLS), SOCKS5 proxy - (outgoing connections and limited incomming), SOCKS4/4a proxy (outgoing - connections and limited incomming), TCP through HTTP proxy tunnel.} + Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin), + SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy + (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.} TTCPBlockSocket = class(TSocksBlockSocket) protected - FSslEnabled: Boolean; - FSslBypass: Boolean; - FSsl: PSSL; - Fctx: PSSL_CTX; - FSSLPassword: string; - FSSLCiphers: string; - FSSLCertificateFile: string; - FSSLPrivateKeyFile: string; - FSSLCertCAFile: string; - FSSLLastError: integer; - FSSLLastErrorDesc: string; - FSSLverifyCert: Boolean; - FSSLType: TSSLType; + FSSL: TCustomSSL; FHTTPTunnelIP: string; FHTTPTunnelPort: string; FHTTPTunnel: Boolean; @@ -893,14 +890,17 @@ type FHTTPTunnelUser: string; FHTTPTunnelPass: string; FHTTPTunnelTimeout: integer; - procedure SetSslEnabled(Value: Boolean); - function SetSslKeys: boolean; - function GetSSLLoaded: Boolean; procedure SocksDoConnect(IP, Port: string); procedure HTTPTunnelDoConnect(IP, Port: string); public + {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation + (see @link(SSLImplementation))} constructor Create; + {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation} + constructor CreateWithSSL(SSLPlugin: TSSLClass); + destructor Destroy; override; + {:See @link(TBlockSocket.CloseSocket)} procedure CloseSocket; override; @@ -939,15 +939,13 @@ type tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP protocol.) - If you additionally use SSL mode, then SSL/TLS session was started. - Note: If you call this on non-created socket, then socket is created automaticly.} procedure Connect(IP, Port: string); override; - {:If you need upgrade existing TCP connection to SSL/TLS mode, then call - this method. This method switch this class to SSL mode and do SSL/TSL - handshake.} + {:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin + allows it) mode, then call this method. This method switch this class to + SSL mode and do SSL/TSL handshake.} procedure SSLDoConnect; {:By this method you can downgrade existing SSL/TLS connection to normal TCP @@ -978,51 +976,6 @@ type {:See @link(TBlockSocket.RecvBuffer)} function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:Return string with identificator of SSL/TLS version of existing - connection.} - function SSLGetSSLVersion: string; - - {:Return subject of remote SSL peer.} - function SSLGetPeerSubject: string; - - {:Return issuer certificate of remote SSL peer.} - function SSLGetPeerIssuer: string; - - {:Return peer name from remote side certificate. This is good for verify, - if certificate is generated for remote side IP name.} - function SSLGetPeerName: string; - - {:Return subject's hash of remote SSL peer.} - function SSLGetPeerSubjectHash: Cardinal; - - {:Return issuer's certificate hash of remote SSL peer.} - function SSLGetPeerIssuerHash: Cardinal; - - {:Return fingerprint of remote SSL peer.} - function SSLGetPeerFingerprint: string; - - {:Return all detailed information about certificate from remote side of - SSL/TLS connection. Result string is multilined!} - function SSLGetCertInfo: string; - - {:Return currently used Cipher.} - function SSLGetCipherName: string; - - {:Return currently used number of bits in current Cipher algorythm.} - function SSLGetCipherBits: integer; - - {:Return number of bits in current Cipher algorythm.} - function SSLGetCipherAlgBits: integer; - - {:Return result value of verify remote side certificate. Look to OpenSSL - documentation for possible values. For example 0 is successfuly verified - certificate, or 18 is self-signed certificate.} - function SSLGetVerifyCert: integer; - - {:Test last SSL operation for errors. If error occured, then is filled - @link(SSLLastError) and @link(SSLLastErrorDesc) properties.} - function SSLCheck: Boolean; - {:Return value of socket type. For TCP return SOCK_STREAM.} function GetSocketType: integer; override; @@ -1030,61 +983,14 @@ type IPPROTO_TCP.} function GetSocketProtocol: integer; override; - {:Is SSL interface loaded or not?} - property SSLLoaded: Boolean read GetSslLoaded; - - {:By this property you can enable or disable SSL mode. Enabling loads needed - OpenSSL or SSLeay libraries. Libraries is loaded to memory only once for - all Synapse's objects. - - Note: when you enable SSL mode, all keys and certificates are loaded (if - needed property is unempty)} - property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled; - - {:Contains last SSL error code.} - property SSLLastError: integer read FSSLLastError; - - {:If some SSL error is occured, then contains human readable description of - this error.} - property SSLLastErrorDesc: string read FSSLLastErrorDesc; + {:Class implementing SSL/TLS support. It is allways some descendant + of @link(TCustomSSL) class. When programmer not select some SSL plugin + class, then is used @link(TSSLNone)} + property SSL: TCustomSSL read FSSL; {:@True if is used HTTP tunnel mode.} property HTTPTunnel: Boolean read FHTTPTunnel; published - {:Here you can specify requested SSL/TLS mode. Default is autodetection, but - on some servers autodetection not working properly. In this case you must - specify requested SSL/TLS mode by your hand!} - property SSLType: TSSLType read FSSLType write FSSLType; - - {:If is SSL mode enabled and this property is @TRUE, then all data (read - and write) will not be encrypted/decrypted.} - property SSLBypass: Boolean read FSslBypass write FSslBypass; - - {:Password for decrypting of encoded certificate. - - Note: This not work with delphi8. You cannot use password protected - certificates with .NET!} - property SSLPassword: string read FSSLPassword write FSSLPassword; - - {:By this property you can modify default set of SSL/TLS ciphers.} - property SSLCiphers: string read FSSLCiphers write FSSLCiphers; - - {:Filename and path to PEM file with your certificate. If certificate need - password for decrypt, you can assign this password to SSLPassword property.} - property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile; - - {:Filename and path to PEM file with your private key.} - property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile; - - {:filename and path to file with bundle of CA certificates. (you may use - ca-bundle.crt file from SynaCert.zip)} - property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile; - - {:If @true, then is verified client certificate. (it is good for writing - SSL/TLS servers.) When you are not server, but you are client, then if this - property is @true, verify servers certificate.} - property SSLverifyCert: Boolean read FSSLverifyCert write FSSLverifyCert; - {:Specify IP address of HTTP proxy. Assingning non-empty value to this property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing TCP connection through HTTP proxy server. (If policy on HTTP proxy server @@ -1201,6 +1107,220 @@ type function GetSocketProtocol: integer; override; end; + {:@abstract(Parent class for all SSL plugins.) + This is abstract class defining interface for other SSL plugins. + + Instance of this class will be created for each @link(TTCPBlockSocket). + + Warning: not all methods and propertis can work in all existing SSL plugins! + Please, read documentation of used SSL plugin.} + TCustomSSL = class(TObject) + protected + FSocket: TTCPBlockSocket; + FSSLEnabled: Boolean; + FLastError: integer; + FLastErrorDesc: string; + FSSLType: TSSLType; + FKeyPassword: string; + FCiphers: string; + FCertificateFile: string; + FPrivateKeyFile: string; + FCertificate: string; + FPrivateKey: string; + FPFX: string; + FPFXfile: string; + FCertCA: string; + FCertCAFile: string; + FTrustCertificate: string; + FTrustCertificateFile: string; + FVerifyCert: Boolean; + FUsername: string; + FPassword: string; + FSSHChannelType: string; + FSSHChannelArg1: string; + FSSHChannelArg2: string; + procedure ReturnError; + function CreateSelfSignedCert(Host: string): Boolean; virtual; + public + {: Create plugin class. it is called internally from @link(TTCPBlockSocket)} + constructor Create(const Value: TTCPBlockSocket); virtual; + + {: Assign settings (certificates and configuration) from another SSL plugin + class.} + procedure Assign(const Value: TCustomSSL); virtual; + + {: return description of used plugin. It usually return name and version + of used SSL library.} + function LibVersion: String; virtual; + + {: return name of used plugin.} + function LibName: String; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for start SSL connection.} + function Connect: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for acept new SSL connection.} + function Accept: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for hard shutdown of SSL connection. (for example, + before socket is closed)} + function Shutdown: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for soft shutdown of SSL connection. (for example, + when you need to continue with unprotected connection.)} + function BiShutdown: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for sending some datas by SSL connection.} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for receiving some datas by SSL connection.} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for getting count of datas what waiting for read. + If SSL plugin not allows this, then it should return 0.} + function WaitingData: Integer; virtual; + + {:Return string with identificator of SSL/TLS version of existing + connection.} + function GetSSLVersion: string; virtual; + + {:Return subject of remote SSL peer.} + function GetPeerSubject: string; virtual; + + {:Return issuer certificate of remote SSL peer.} + function GetPeerIssuer: string; virtual; + + {:Return peer name from remote side certificate. This is good for verify, + if certificate is generated for remote side IP name.} + function GetPeerName: string; virtual; + + {:Return fingerprint of remote SSL peer.} + function GetPeerFingerprint: string; virtual; + + {:Return all detailed information about certificate from remote side of + SSL/TLS connection. Result string can be multilined! Each plugin can return + this informations in different format!} + function GetCertInfo: string; virtual; + + {:Return currently used Cipher.} + function GetCipherName: string; virtual; + + {:Return currently used number of bits in current Cipher algorythm.} + function GetCipherBits: integer; virtual; + + {:Return number of bits in current Cipher algorythm.} + function GetCipherAlgBits: integer; virtual; + + {:Return result value of verify remote side certificate. Look to OpenSSL + documentation for possible values. For example 0 is successfuly verified + certificate, or 18 is self-signed certificate.} + function GetVerifyCert: integer; virtual; + + {: Resurn @true if SSL mode is enabled on existing cvonnection.} + property SSLEnabled: Boolean read FSSLEnabled; + + {:Return error code of last SSL operation. 0 is OK.} + property LastError: integer read FLastError; + + {:Return error description of last SSL operation.} + property LastErrorDesc: string read FLastErrorDesc; + published + {:Here you can specify requested SSL/TLS mode. Default is autodetection, but + on some servers autodetection not working properly. In this case you must + specify requested SSL/TLS mode by your hand!} + property SSLType: TSSLType read FSSLType write FSSLType; + + {:Password for decrypting of encoded certificate or key.} + property KeyPassword: string read FKeyPassword write FKeyPassword; + + {:Username for possible credentials.} + property Username: string read FUsername write FUsername; + + {:password for possible credentials.} + property Password: string read FPassword write FPassword; + + {:By this property you can modify default set of SSL/TLS ciphers.} + property Ciphers: string read FCiphers write FCiphers; + + {:Used for loading certificate from disk file. See to plugin documentation + if this method is supported and how!} + property CertificateFile: string read FCertificateFile write FCertificateFile; + + {:Used for loading private key from disk file. See to plugin documentation + if this method is supported and how!} + property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile; + + {:Used for loading certificate from binary string. See to plugin documentation + if this method is supported and how!} + property Certificate: string read FCertificate write FCertificate; + + {:Used for loading private key from binary string. See to plugin documentation + if this method is supported and how!} + property PrivateKey: string read FPrivateKey write FPrivateKey; + + {:Used for loading PFX from binary string. See to plugin documentation + if this method is supported and how!} + property PFX: string read FPFX write FPFX; + + {:Used for loading PFX from disk file. See to plugin documentation + if this method is supported and how!} + property PFXfile: string read FPFXfile write FPFXfile; + + {:Used for loading trusted certificates from disk file. See to plugin documentation + if this method is supported and how!} + property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile; + + {:Used for loading trusted certificates from binary string. See to plugin documentation + if this method is supported and how!} + property TrustCertificate: string read FTrustCertificate write FTrustCertificate; + + {:Used for loading CA certificates from binary string. See to plugin documentation + if this method is supported and how!} + property CertCA: string read FCertCA write FCertCA; + + {:Used for loading CA certificates from disk file. See to plugin documentation + if this method is supported and how!} + property CertCAFile: string read FCertCAFile write FCertCAFile; + + {:If @true, then is verified client certificate. (it is good for writing + SSL/TLS servers.) When you are not server, but you are client, then if this + property is @true, verify servers certificate.} + property VerifyCert: Boolean read FVerifyCert write FVerifyCert; + + {:channel type for possible SSH connections} + property SSHChannelType: string read FSSHChannelType write FSSHChannelType; + + {:First argument of channel type for possible SSH connections} + property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1; + + {:Second argument of channel type for possible SSH connections} + property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2; + end; + + {:@abstract(Default SSL plugin with no SSL support.) + Dummy SSL plugin implementation for applications without SSL/TLS support.} + TSSLNone = class (TCustomSSL) + public + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + end; + {:@abstract(Record with definition of IP packet header.) For reading data from ICMP or RAW sockets.} TIPHeader = record @@ -1250,6 +1370,15 @@ type property Password: string read FPassword Write FPassword; end; +var + {:Selected SSL plugin. Default is @link(TSSLNone). + + Do not change this value directly!!! + + Just add your plugin unit to your project uses instead. Each plugin unit have + initialization code what modify this variable.} + SSLImplementation: TSSLClass = TSSLNone; + implementation {$IFDEF ONCEWINSOCK} @@ -1913,7 +2042,6 @@ begin begin FStopFlag := False; FLastError := WSAECONNABORTED; - FLastErrorDesc := GetErrorDesc(FLastError); ExceptCheck; end; end; @@ -1930,7 +2058,7 @@ begin Result := 0; if TestStopFlag then Exit; - DoWriteFilter(Buffer, Length); + DoMonitor(True, Buffer, Length); {$IFDEF CIL} Result := synsock.Send(FSocket, Buffer, Length, 0); {$ELSE} @@ -2030,6 +2158,8 @@ begin if yr > 0 then begin SendBuffer(buf, yr); + if FLastError <> 0 then + break; Inc(x, yr); end else @@ -2041,6 +2171,8 @@ begin begin SetLength(s, yr); SendString(s); + if FLastError <> 0 then + break; Inc(x, yr); end else @@ -2083,6 +2215,7 @@ begin ExceptCheck; Inc(FRecvCounter, Result); DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); DoReadFilter(Buffer, Result); end; @@ -2504,10 +2637,10 @@ end; procedure TBlockSocket.Purge; begin + Sleep(1); try - repeat + while (Length(FBuffer) > 0) or (WaitingData > 0) do RecvPacket(0); - until FLastError <> 0; except on exception do; end; @@ -2696,7 +2829,7 @@ begin Hints.ai_protocol := GetSocketprotocol; Hints.ai_flags := AI_PASSIVE; r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - if r = 0 then + if (r = 0) and Assigned(Addr) then begin if Addr^.ai_family = AF_INET then Result := synsock.htons(Addr^.ai_addr^.sin_port); @@ -2755,7 +2888,7 @@ begin Hints.ai_protocol := GetSocketprotocol; Hints.ai_flags := 0; r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); - if r = 0 then + if (r = 0) and Assigned(Addr)then begin hostlen := NI_MAXHOST; servlen := NI_MAXSERV; @@ -2869,6 +3002,7 @@ begin Result := 0; if TestStopFlag then Exit; + DoMonitor(True, Buffer, Length); LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); Result := synsock.SendTo(FSocket, Buffer, Length, 0, FRemoteSin); SockCheck(Result); @@ -2888,6 +3022,7 @@ begin ExceptCheck; Inc(FRecvCounter, Result); DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); end; function TBlockSocket.GetSizeRecvBuffer: Integer; @@ -3119,7 +3254,7 @@ begin Hints.ai_family := AF_INET6; Hints.ai_flags := AI_NUMERICHOST; r := synsock.GetAddrInfo(PChar(value), nil, @Hints, Addr); - if r = 0 then + if (r = 0) and Assigned(Addr) then if (Addr^.ai_family = AF_INET6) then Move(Addr^.ai_addr^, Result, SizeOf(Result)); finally @@ -3224,37 +3359,20 @@ begin end; end; -procedure TBlockSocket.DoWriteFilter(Buffer: TMemory; var Len: Integer); -var - s: string; -begin - if assigned(OnWriteFilter) then - if Len > 0 then - begin - {$IFDEF CIL} - s := StringOf(Buffer); - {$ELSE} - SetLength(s, Len); - Move(Buffer^, Pointer(s)^, Len); - {$ENDIF} - OnWriteFilter(Self, s); - if Length(s) > Len then - SetLength(s, Len); - Len := Length(s); - {$IFDEF CIL} - Buffer := BytesOf(s); - {$ELSE} - Move(Pointer(s)^, Buffer^, Len); - {$ENDIF} - end; -end; - procedure TBlockSocket.DoCreateSocket; begin if assigned(OnCreateSocket) then OnCreateSocket(Self); end; +procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); +begin + if assigned(OnMonitor) then + begin + OnMonitor(Self, Writing, Buffer, Len); + end; +end; + class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; begin {$IFDEF CIL} @@ -3880,37 +3998,10 @@ begin end; {======================================================================} - -{$IFNDEF CIL} -function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; -var - Password: String; -begin - Password := ''; - if TTCPBlockSocket(userdata) is TTCPBlockSocket then - Password := TTCPBlockSocket(userdata).SSLPassword; - if Length(Password) > (Size - 1) then - SetLength(Password, Size - 1); - Result := Length(Password); - StrLCopy(buf, PChar(Password + #0), Result + 1); -end; -{$ENDIF} - -constructor TTCPBlockSocket.Create; +constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass); begin inherited Create; - FSslEnabled := False; - FSslBypass := False; - FSSLCiphers := 'DEFAULT'; - FSSLCertificateFile := ''; - FSSLPrivateKeyFile := ''; - FSSLPassword := ''; - FSsl := nil; - Fctx := nil; - FSSLLastError := 0; - FSSLLastErrorDesc := ''; - FSSLverifyCert := False; - FSSLType := LT_all; + FSSL := SSLPlugin.Create(self); FHTTPTunnelIP := ''; FHTTPTunnelPort := ''; FHTTPTunnel := False; @@ -3921,14 +4012,21 @@ begin FHTTPTunnelTimeout := 30000; end; +constructor TTCPBlockSocket.Create; +begin + CreateWithSSL(SSLImplementation); +end; + +destructor TTCPBlockSocket.Destroy; +begin + inherited Destroy; + FSSL.Free; +end; + procedure TTCPBlockSocket.CloseSocket; begin - if SSLEnabled then - begin - if assigned(FSsl) then - sslshutdown(FSsl); - FSSLEnabled := false; - end; + if FSSL.SSLEnabled then + FSSL.Shutdown; if FSocket <> INVALID_SOCKET then begin Synsock.Shutdown(FSocket, 1); @@ -3940,8 +4038,8 @@ end; function TTCPBlockSocket.WaitingData: Integer; begin Result := 0; - if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then - Result := sslpending(Fssl); + if FSSL.SSLEnabled then + Result := FSSL.WaitingData; if Result = 0 then Result := inherited WaitingData; end; @@ -4001,8 +4099,6 @@ begin end; procedure TTCPBlockSocket.Connect(IP, Port: string); -var - x: integer; begin if FSocksIP <> '' then SocksDoConnect(IP, Port) @@ -4011,15 +4107,6 @@ begin HTTPTunnelDoConnect(IP, Port) else inherited Connect(IP, Port); - if FSslEnabled then - if FLastError = 0 then - SSLDoConnect - else - begin - x := FLastError; - SSLEnabled := False; - FLastError := x; - end; end; procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); @@ -4050,91 +4137,44 @@ procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); var s: string; begin - try - Port := IntToStr(ResolvePort(Port)); - FBypassFlag := True; - inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); + Port := IntToStr(ResolvePort(Port)); + inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); + if FLastError <> 0 then + Exit; + FHTTPTunnel := False; + if IsIP6(IP) then + IP := '[' + IP + ']'; + SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF); + if FHTTPTunnelUser <> '' then + Sendstring('Proxy-Authorization: Basic ' + + EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); + SendString(CRLF); + repeat + s := RecvTerminated(FHTTPTunnelTimeout, #$0a); if FLastError <> 0 then - Exit; - FHTTPTunnel := False; - if IsIP6(IP) then - IP := '[' + IP + ']'; - SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF); - if FHTTPTunnelUser <> '' then - Sendstring('Proxy-Authorization: Basic ' + - EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); - SendString(CRLF); - repeat - s := RecvTerminated(FHTTPTunnelTimeout, #$0a); - if FLastError <> 0 then - Break; - if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then - FHTTPTunnel := s[10] = '2'; - until (s = '') or (s = #$0d); - if (FLasterror = 0) and not FHTTPTunnel then - FLastError := WSASYSNOTREADY; - FHTTPTunnelRemoteIP := IP; - FHTTPTunnelRemotePort := Port; - finally - FBypassFlag := False; - end; + Break; + if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then + FHTTPTunnel := s[10] = '2'; + until (s = '') or (s = #$0d); + if (FLasterror = 0) and not FHTTPTunnel then + FLastError := WSASYSNOTREADY; + FHTTPTunnelRemoteIP := IP; + FHTTPTunnelRemotePort := Port; ExceptCheck; end; procedure TTCPBlockSocket.SSLDoConnect; -var - x: integer; begin FLastError := 0; - if not FSSLEnabled then - SSLEnabled := True; - if (FLastError = 0) then -{$IFDEF CIL} - if sslsetfd(FSsl, FSocket.Handle.ToInt32) < 1 then -{$ELSE} - if sslsetfd(FSsl, FSocket) < 1 then -{$ENDIF} - begin - FLastError := WSASYSNOTREADY; - SSLCheck; - end; - if (FLastError = 0) then - begin - x := sslconnect(FSsl); - if x < 1 then - begin - FLastError := WSASYSNOTREADY; - SSLcheck; - end; - end; - if FSSLverifyCert then - if SSLGetVerifyCert <> 0 then - FLastError := WSAEACCES; - if FLastError <> 0 then - begin - x := FLastError; - SSLEnabled := False; - FLastError := x; - end; + if not FSSL.Connect then + FLastError := WSASYSNOTREADY; ExceptCheck; end; procedure TTCPBlockSocket.SSLDoShutdown; -var - x: integer; begin FLastError := 0; - if assigned(FSsl) then - begin - x := sslshutdown(FSsl); - if x = 0 then - begin - Synsock.Shutdown(FSocket, 1); - sslshutdown(FSsl); - end; - end; - SSLEnabled := False; - ExceptCheck; + FSSL.BiShutdown; end; function TTCPBlockSocket.GetLocalSinIP: string; @@ -4175,169 +4215,21 @@ begin Result := inherited GetRemoteSinPort; end; -function TTCPBlockSocket.SSLCheck: Boolean; -var - ErrBuf: String; -begin - Result := true; - FSSLLastErrorDesc := ''; - FSSLLastError := ErrGetError; - ErrClearError; - if FSSLLastError <> 0 then - begin - Result := False; - ErrBuf := StringOfChar(#0, 256); - FSSLLastErrorDesc := ErrErrorString(FSSLLastError, ErrBuf); - end; -end; - -function TTCPBlockSocket.GetSSLLoaded: Boolean; -begin - Result := IsSSLLoaded; -end; - -function TTCPBlockSocket.SetSslKeys: boolean; -begin - if not assigned(FCtx) then - begin - Result := False; - Exit; - end - else - Result := True; - if FSSLCertificateFile <> '' then - if SslCtxUseCertificateChainFile(FCtx, FSSLCertificateFile) <> 1 then - begin - Result := False; - SSLCheck; - Exit; - end; - if FSSLPrivateKeyFile <> '' then - if SslCtxUsePrivateKeyFile(FCtx, FSSLPrivateKeyFile, 1) <> 1 then - begin - Result := False; - SSLCheck; - Exit; - end; - if FSSLCertCAFile <> '' then - if SslCtxLoadVerifyLocations(FCtx, FSSLCertCAFile, '') <> 1 then - begin - Result := False; - SSLCheck; - end; -end; - -procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean); -var - err: Boolean; -begin - FLastError := 0; - if Value <> FSslEnabled then - if Value then - begin - FBuffer := ''; - FSSLLastErrorDesc := ''; - FSSLLastError := 0; - if InitSSLInterface then - begin - err := False; - 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); - end; - if Fctx = nil then - begin - SSLCheck; - FlastError := WSAEPROTONOSUPPORT; - err := True; - end - else - begin - SslCtxSetCipherList(Fctx, FSSLCiphers); - if FSSLverifyCert then - SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) - else - SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); -{$IFNDEF CIL} - SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); - SslCtxSetDefaultPasswdCbUserdata(FCtx, self); -{$ENDIF} - if not SetSSLKeys then - FLastError := WSAEINVAL - else - begin - Fssl := nil; - Fssl := SslNew(Fctx); - if Fssl = nil then - begin - SSLCheck; - FlastError := WSAEPROTONOSUPPORT; - err := True; - end; - end; - end; - FSslEnabled := not err; - end - else - FlastError := WSAEPROTONOSUPPORT; - end - else - begin - FBuffer := ''; - sslfree(Fssl); - Fssl := nil; - SslCtxFree(Fctx); - Fctx := nil; - ErrRemoveState(0); - FSslEnabled := False; - end; - ExceptCheck; -end; - function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -var - err: integer; -{$IFDEF CIL} - sb: stringbuilder; - s: ansistring; -{$ENDIF} begin - if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then + if FSSL.SSLEnabled then begin Result := 0; if TestStopFlag then Exit; FLastError := 0; - 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 := WSASYSNOTREADY; + Result := FSSL.RecvBuffer(Buffer, Len); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; ExceptCheck; Inc(FRecvCounter, Result); DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); DoReadFilter(Buffer, Result); end else @@ -4346,36 +4238,25 @@ end; function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; var - err: integer; x, y: integer; l, r: integer; -{$IFDEF CIL} - s: string; -{$ELSE} +{$IFNDEF CIL} p: Pointer; {$ENDIF} begin - if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then + if FSSL.SSLEnabled then begin Result := 0; if TestStopFlag then Exit; FLastError := 0; - DoWriteFilter(Buffer, Length); + DoMonitor(True, Buffer, Length); {$IFDEF CIL} - s := StringOf(Buffer); - repeat - r := SslWrite(FSsl, s, Length); - err := SslGetError(FSsl, r); - until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); - if err = SSL_ERROR_ZERO_RETURN then - r := 0 - else - if (err <> 0) then - FLastError := WSASYSNOTREADY; - Result := r; - Inc(FSendCounter, r); - DoStatus(HR_WriteCount, IntToStr(r)); + Result := FSSL.SendBuffer(Buffer, Length); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; + Inc(FSendCounter, Result); + DoStatus(HR_WriteCount, IntToStr(Result)); {$ELSE} l := Length; x := 0; @@ -4388,15 +4269,9 @@ begin begin LimitBandwidth(y, FMaxSendBandwidth, FNextsend); p := IncPoint(Buffer, x); - repeat - r := SslWrite(FSsl, p, y); - err := SslGetError(FSsl, r); - until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); - if err = SSL_ERROR_ZERO_RETURN then - r := 0 - else - if (err <> 0) then - FLastError := WSASYSNOTREADY; + r := FSSL.SendBuffer(p, y); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; if Flasterror <> 0 then Break; Inc(x, r); @@ -4415,232 +4290,14 @@ begin end; function TTCPBlockSocket.SSLAcceptConnection: Boolean; -var - x: integer; begin FLastError := 0; - if not FSSLEnabled then - SSLEnabled := True; - if (FLastError = 0) then - begin -{$IFDEF CIL} - x := FSocket.Handle.ToInt32; - if sslsetfd(FSsl, x) < 1 then -{$ELSE} - if sslsetfd(FSsl, FSocket) < 1 then -{$ENDIF} - begin - FLastError := WSASYSNOTREADY; - SSLCheck; - end; - end; - if (FLastError = 0) then - if sslAccept(FSsl) < 1 then - FLastError := WSASYSNOTREADY; - if FLastError <> 0 then - begin - x := FLastError; - SSLEnabled := False; - FLastError := x; - end; + if not FSSL.Accept then + FLastError := WSASYSNOTREADY; ExceptCheck; Result := FLastError = 0; end; -function TTCPBlockSocket.SSLGetSSLVersion: string; -begin - if not assigned(FSsl) then - Result := '' - else - Result := SSlGetVersion(FSsl); -end; - -function TTCPBlockSocket.SSLGetPeerSubject: 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 := SslX509NameOneline(SslX509GetSubjectName(cert), sb, 4096); -{$ELSE} - setlength(s, 4096); - Result := SslX509NameOneline(SslX509GetSubjectName(cert), s, Length(s)); -{$ENDIF} - SslX509Free(cert); -end; - -function TTCPBlockSocket.SSLGetPeerName: string; -var - s: string; -begin - s := SSLGetPeerSubject; - s := SeparateRight(s, '/CN='); - Result := Trim(SeparateLeft(s, '/')); -end; - -function TTCPBlockSocket.SSLGetPeerIssuer: 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 := SslX509NameOneline(SslX509GetIssuerName(cert), sb, 4096); -{$ELSE} - setlength(s, 4096); - Result := SslX509NameOneline(SslX509GetIssuerName(cert), s, Length(s)); -{$ENDIF} - SslX509Free(cert); -end; - -function TTCPBlockSocket.SSLGetPeerSubjectHash: Cardinal; -var - cert: PX509; -begin - if not assigned(FSsl) then - begin - Result := 0; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - Result := SslX509NameHash(SslX509GetSubjectName(cert)); - SslX509Free(cert); -end; - -function TTCPBlockSocket.SSLGetPeerIssuerHash: Cardinal; -var - cert: PX509; -begin - if not assigned(FSsl) then - begin - Result := 0; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - Result := SslX509NameHash(SslX509GetIssuerName(cert)); - SslX509Free(cert); -end; - -function TTCPBlockSocket.SSLGetPeerFingerprint: 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); - SslX509Digest(cert, SslEvpMd5, sb, x); - sb.Length := x; - Result := sb.ToString; -{$ELSE} - setlength(Result, EVP_MAX_MD_SIZE); - SslX509Digest(cert, SslEvpMd5, Result, x); - SetLength(Result, x); -{$ENDIF} - SslX509Free(cert); -end; - -function TTCPBlockSocket.SSLGetCertInfo: 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 TTCPBlockSocket.SSLGetCipherName: string; -begin - if not assigned(FSsl) then - Result := '' - else - Result := SslCipherGetName(SslGetCurrentCipher(FSsl)); -end; - -function TTCPBlockSocket.SSLGetCipherBits: integer; -var - x: integer; -begin - if not assigned(FSsl) then - Result := 0 - else - Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x); -end; - -function TTCPBlockSocket.SSLGetCipherAlgBits: integer; -begin - if not assigned(FSsl) then - Result := 0 - else - SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result); -end; - -function TTCPBlockSocket.SSLGetVerifyCert: integer; -begin - if not assigned(FSsl) then - Result := 1 - else - Result := SslGetVerifyResult(FSsl); -end; - function TTCPBlockSocket.GetSocketType: integer; begin Result := integer(SOCK_STREAM); @@ -4693,6 +4350,181 @@ end; {======================================================================} +constructor TCustomSSL.Create(const Value: TTCPBlockSocket); +begin + inherited Create; + FSocket := Value; + FSSLEnabled := False; + FUsername := ''; + FPassword := ''; + FLastError := 0; + FLastErrorDesc := ''; + FVerifyCert := False; + FSSLType := LT_all; + FKeyPassword := ''; + FCiphers := ''; + FCertificateFile := ''; + FPrivateKeyFile := ''; + FCertCAFile := ''; + FCertCA := ''; + FTrustCertificate := ''; + FTrustCertificateFile := ''; + FCertificate := ''; + FPrivateKey := ''; + FPFX := ''; + FPFXfile := ''; + FSSHChannelType := ''; + FSSHChannelArg1 := ''; + FSSHChannelArg2 := ''; +end; + +procedure TCustomSSL.Assign(const Value: TCustomSSL); +begin + FUsername := Value.Username; + FPassword := Value.Password; + FVerifyCert := Value.VerifyCert; + FSSLType := Value.SSLType; + FKeyPassword := Value.KeyPassword; + FCiphers := Value.Ciphers; + FCertificateFile := Value.CertificateFile; + FPrivateKeyFile := Value.PrivateKeyFile; + FCertCAFile := Value.CertCAFile; + FCertCA := Value.CertCA; + FTrustCertificate := Value.TrustCertificate; + FTrustCertificateFile := Value.TrustCertificateFile; + FCertificate := Value.Certificate; + FPrivateKey := Value.PrivateKey; + FPFX := Value.PFX; + FPFXfile := Value.PFXfile; +end; + +procedure TCustomSSL.ReturnError; +begin + FLastError := -1; + FLastErrorDesc := 'SLL is not implemented!'; +end; + +function TCustomSSL.LibVersion: String; +begin + Result := ''; +end; + +function TCustomSSL.LibName: String; +begin + Result := ''; +end; + +function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean; +begin + Result := False; +end; + +function TCustomSSL.Connect: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.Accept: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.Shutdown: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.BiShutdown: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + ReturnError; + Result := integer(SOCKET_ERROR); +end; + +function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + ReturnError; + Result := integer(SOCKET_ERROR); +end; + +function TCustomSSL.WaitingData: Integer; +begin + ReturnError; + Result := 0; +end; + +function TCustomSSL.GetSSLVersion: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerSubject: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerName: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerIssuer: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerFingerprint: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCertInfo: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCipherName: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCipherBits: integer; +begin + Result := 0; +end; + +function TCustomSSL.GetCipherAlgBits: integer; +begin + Result := 0; +end; + +function TCustomSSL.GetVerifyCert: integer; +begin + Result := 1; +end; + +{======================================================================} + +function TSSLNone.LibVersion: String; +begin + Result := 'Without SSL support'; +end; + +function TSSLNone.LibName: String; +begin + Result := 'ssl_none'; +end; + +{======================================================================} + {$IFDEF ONCEWINSOCK} initialization begin diff --git a/dnssend.pas b/dnssend.pas index b4175a8..2e21865 100644 --- a/dnssend.pas +++ b/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 diff --git a/ftpsend.pas b/ftpsend.pas index ddfb56c..1c1ff1c 100644 --- a/ftpsend.pas +++ b/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} - if Assigned(FTLSServer) then - begin - FDSock.TLSServer := FTLSServer; - FDSock.Connect('',''); - Result := FDSock.LastError = 0; - end - else - Result := False; -{$ELSE} + FDSock.SSL.Assign(FSock.SSL); 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 - Exit; + b := FDSock.LastError = 0; 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 diff --git a/httpsend.pas b/httpsend.pas index 7b17a86..2e9e937 100644 --- a/httpsend.pas +++ b/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); - Response.CopyFrom(HTTP.Document, 0); + if Result then + 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); - Data.CopyFrom(HTTP.Document, 0); + if Result then + 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; diff --git a/imapsend.pas b/imapsend.pas index 8cff691..91b2d85 100644 --- a/imapsend.pas +++ b/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; diff --git a/ldapsend.pas b/ldapsend.pas index 8251717..efac6b6 100644 --- a/ldapsend.pas +++ b/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; diff --git a/mimeinln.pas b/mimeinln.pas index 7407233..978a0f2 100644 --- a/mimeinln.pas +++ b/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; diff --git a/mimemess.pas b/mimemess.pas index 21f1995..ced9ffb 100644 --- a/mimemess.pas +++ b/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); diff --git a/mimepart.pas b/mimepart.pas index d0e088f..f3e91a3 100644 --- a/mimepart.pas +++ b/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 uppercase(FSecondary) = 'HTML' then + if FConvertCharset and (FPrimaryCode = MP_TEXT) then + if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then begin - b := False; - for n := 0 to FPartBody.Count - 1 do - begin - t := uppercase(FPartBody[n]); - if Pos('HTTP-EQUIV', t) > 0 then - if Pos('CONTENT-TYPE', t) > 0 then - begin - b := True; - Break; - end; - if Pos('', t) > 0 then - Break; - end; + t := uppercase(s); + t := SeparateLeft(t, ''); + t := SeparateRight(t, ''); + t := ReplaceString(t, '"', ''); + t := ReplaceString(t, ' ', ''); + b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; 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); -// Setlength(s, 54); -// x := FDecodedLines.Read(pointer(s)^, 54); -// Setlength(s, x); - if FPrimaryCode = MP_TEXT then + x := 1; + while x <= length(s) do begin - s := CharsetConversion(s, FTargetCharset, FCharsetCode); - if NeedBOM then - begin - s := GetBOM(FCharSetCode) + s; - NeedBOM := False; - end; + t := copy(s, x, 54); + x := x + length(t); + t := EncodeBase64(t); + FPartBody.Add(t); 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_TEXT) and (FEncodingCode <> ME_7BIT) then - 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 + if FPrimaryCode = MP_BINARY then + l.Add(s) 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; diff --git a/nntpsend.pas b/nntpsend.pas index f3f6f34..1617acf 100644 --- a/nntpsend.pas +++ b/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; diff --git a/pop3send.pas b/pop3send.pas index c814075..33d35b9 100644 --- a/pop3send.pas +++ b/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; diff --git a/slogsend.pas b/slogsend.pas index 0e520af..9c0625d 100644 --- a/slogsend.pas +++ b/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; diff --git a/smtpsend.pas b/smtpsend.pas index f0ce4d1..47ff6fd 100644 --- a/smtpsend.pas +++ b/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; diff --git a/snmpsend.pas b/snmpsend.pas index 8826f5a..fc39c9b 100644 --- a/snmpsend.pas +++ b/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; diff --git a/sntpsend.pas b/sntpsend.pas index 4cc4021..dd40de3 100644 --- a/sntpsend.pas +++ b/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); diff --git a/ssl_cryptlib.pas b/ssl_cryptlib.pas new file mode 100644 index 0000000..ec76bae --- /dev/null +++ b/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. + diff --git a/ssl_openssl.pas b/ssl_openssl.pas new file mode 100644 index 0000000..5452705 --- /dev/null +++ b/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. diff --git a/synassl.pas b/ssl_openssl_lib.pas similarity index 60% rename from synassl.pas rename to ssl_openssl_lib.pas index fa7d5b6..0a2db22 100644 --- a/synassl.pas +++ b/ssl_openssl_lib.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.000.002 | +| Project : Ararat Synapse | 003.004.000 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| -| 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)2002-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2002-2005. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -57,11 +57,16 @@ Special thanks to Gregor Ibic {$ENDIF} {$IFDEF BCB} {$ObjExportAll On} - (*$HPPEMIT 'namespace Synassl { using System::Shortint; }' *) + (*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *) {$ENDIF} -{:@exclude} -unit synassl; +{:@abstract(OpenSSL support) + +This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit). +OpenSSL is loaded dynamicly on-demand. If this library is not found in system, +requested OpenSSL function just return errorcode. +} +unit ssl_openssl_lib; interface @@ -70,6 +75,7 @@ uses System.Runtime.InteropServices, System.Text, {$ENDIF} + Classes, {$IFDEF LINUX} {$IFDEF FPC} synafpc, @@ -107,6 +113,7 @@ type {$ELSE} SslPtr = Pointer; {$ENDIF} + PSslPtr = ^SslPtr; PSSL_CTX = SslPtr; PSSL = SslPtr; PSSL_METHOD = SslPtr; @@ -116,6 +123,10 @@ type PInteger = ^Integer; PBIO_METHOD = SslPtr; PBIO = SslPtr; + EVP_PKEY = SslPtr; + PRSA = SslPtr; + PASN1_UTCTIME = SslPtr; + PASN1_INTEGER = SslPtr; PPasswdCb = SslPtr; PFunction = procedure; @@ -189,6 +200,10 @@ const //The application is not happy X509_V_ERR_APPLICATION_VERIFICATION = 50; + SSL_FILETYPE_ASN1 = 2; + SSL_FILETYPE_PEM = 1; + EVP_PKEY_RSA = 6; + var SSLLibHandle: Integer = 0; SSLUtilHandle: Integer = 0; @@ -253,12 +268,37 @@ var [DllImport(DLLSSLName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_PrivateKey_file')] + EntryPoint = 'SSL_CTX_use_PrivateKey')] + function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_PrivateKey_ASN1')] + function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_RSAPrivateKey_file')] function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; external; [DllImport(DLLSSLName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_certificate_chain_file')] //TODO: See if this is really correct + EntryPoint = 'SSL_CTX_use_certificate')] + function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_ASN1')] + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_file')] + function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_chain_file')] function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer;external; [DllImport(DLLSSLName, CharSet = CharSet.Ansi, @@ -361,45 +401,126 @@ var EntryPoint = 'SSL_get_verify_result')] function SSLGetVerifyResult(ssl: PSSL):Integer;external; + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_new')] + function X509New: PX509; external; + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, EntryPoint = 'X509_free')] - procedure SslX509Free(x: PX509); external; + procedure X509Free(x: PX509); external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, EntryPoint = 'X509_NAME_oneline')] - function SslX509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): String; external; + function X509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): String; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, EntryPoint = 'X509_get_subject_name')] - function SslX509GetSubjectName(a: PX509):PX509_NAME; external; + function X509GetSubjectName(a: PX509):PX509_NAME; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, EntryPoint = 'X509_get_issuer_name')] - function SslX509GetIssuerName(a: PX509):PX509_NAME; external; + function X509GetIssuerName(a: PX509):PX509_NAME; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, EntryPoint = 'X509_NAME_hash')] - function SslX509NameHash(x: PX509_NAME):Cardinal; external; + function X509NameHash(x: PX509_NAME):Cardinal; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, EntryPoint = 'X509_digest')] - function SslX509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external; + function X509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_md5')] - function SslEvpMd5:PEVP_MD; external; + EntryPoint = 'X509_set_version')] + function X509SetVersion(x: PX509; version: integer): integer; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_error_string')] - function ErrErrorString(e: integer; var buf: String): String; external; + EntryPoint = 'X509_set_pubkey')] + function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_issuer_name')] + function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_add_entry_by_txt')] + function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer; + bytes: string; len, loc, _set: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_sign')] + function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_print')] + function X509print(b: PBIO; a: PX509): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_gmtime_adj')] + function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_notBefore')] + function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_notAfter')] + function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_serialNumber')] + function X509GetSerialNumber(x: PX509): PASN1_INTEGER; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_new')] + function EvpPkeyNew: EVP_PKEY; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_free')] + procedure EvpPkeyFree(pk: EVP_PKEY); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_assign')] + function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_get_digestbyname')] + function EvpGetDigestByName(Name: String): PEVP_MD; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_cleanup')] + procedure EVPcleanup; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLeay_version')] + function SSLeayversion(t: integer): String; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_error_string_n')] + procedure ErrErrorString(e: integer; buf: StringBuilder; len: integer); external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, @@ -408,7 +529,7 @@ var [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_clean_error')] + EntryPoint = 'ERR_clear_error')] procedure ErrClearError; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, @@ -423,8 +544,8 @@ var [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_cleanup')] - procedure EVPcleanup; external; + EntryPoint = 'OPENSSL_add_all_algorithms_noconf')] + procedure OPENSSLaddallalgorithms; external; [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, @@ -468,8 +589,48 @@ var [DllImport(DLLUtilName, CharSet = CharSet.Ansi, SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_print')] - function X509print(b: PBIO; a: PX509): integer; external; + EntryPoint = 'd2i_PKCS12_bio')] + function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'PKCS12_parse')] + function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'PKCS12_free')] + procedure PKCS12free(p12: SslPtr); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'RSA_generate_key')] + function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_UTCTIME_new')] + function Asn1UtctimeNew: PASN1_UTCTIME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_UTCTIME_free')] + procedure Asn1UtctimeFree(a: PASN1_UTCTIME); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_INTEGER_set')] + function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'i2d_X509_bio')] + function i2dX509bio(b: PBIO; x: PX509): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'i2d_PrivateKey_bio')] + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; external; // 3DES functions [DllImport(DLLUtilName, CharSet = CharSet.Ansi, @@ -487,7 +648,6 @@ var EntryPoint = 'DES_ecb_encrypt')] procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); external; - {$ELSE} // libssl.dll function SslGetError(s: PSSL; ret_code: Integer):Integer; @@ -502,8 +662,13 @@ var function SslMethodV3:PSSL_METHOD; function SslMethodTLSV1:PSSL_METHOD; function SslMethodV23:PSSL_METHOD; + function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; + function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer; // function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; + function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer; + function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; // function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer; function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; @@ -529,21 +694,38 @@ var function SSLGetVerifyResult(ssl: PSSL):Integer; // libeay.dll - procedure SslX509Free(x: PX509); - function SslX509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String; - function SslX509GetSubjectName(a: PX509):PX509_NAME; - function SslX509GetIssuerName(a: PX509):PX509_NAME; - function SslX509NameHash(x: PX509_NAME):Cardinal; + function X509New: PX509; + procedure X509Free(x: PX509); + function X509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String; + function X509GetSubjectName(a: PX509):PX509_NAME; + function X509GetIssuerName(a: PX509):PX509_NAME; + function X509NameHash(x: PX509_NAME):Cardinal; // function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; - function SslX509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer; - function SslEvpMd5:PEVP_MD; + function X509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer; + function X509print(b: PBIO; a: PX509): integer; + function X509SetVersion(x: PX509; version: integer): integer; + function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; + function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; + function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer; + bytes: string; len, loc, _set: integer): integer; + function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; + function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; + function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; + function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; + function X509GetSerialNumber(x: PX509): PASN1_INTEGER; + function EvpPkeyNew: EVP_PKEY; + procedure EvpPkeyFree(pk: EVP_PKEY); + function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; + function EvpGetDigestByName(Name: String): PEVP_MD; + procedure EVPcleanup; // function ErrErrorString(e: integer; buf: PChar): PChar; - function ErrErrorString(e: integer; var buf: String): String; + function SSLeayversion(t: integer): string; + procedure ErrErrorString(e: integer; var buf: string; len: integer); function ErrGetError: integer; procedure ErrClearError; procedure ErrFreeStrings; procedure ErrRemoveState(pid: integer); - procedure EVPcleanup; + procedure OPENSSLaddallalgorithms; procedure CRYPTOcleanupAllExData; procedure RandScreen; function BioNew(b: PBIO_METHOD): PBIO; @@ -552,7 +734,16 @@ var function BioCtrlPending(b: PBIO): integer; function BioRead(b: PBIO; var Buf: String; Len: integer): integer; function BioWrite(b: PBIO; Buf: String; Len: integer): integer; - function X509print(b: PBIO; a: PX509): integer; + function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; + function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; + procedure PKCS12free(p12: SslPtr); + function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; + function Asn1UtctimeNew: PASN1_UTCTIME; + procedure Asn1UtctimeFree(a: PASN1_UTCTIME); + function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; + function i2dX509bio(b: PBIO; x: PX509): integer; + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; + // 3DES functions procedure DESsetoddparity(Key: des_cblock); function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; @@ -582,11 +773,16 @@ type TSslMethodV3 = function:PSSL_METHOD; cdecl; TSslMethodTLSV1 = function:PSSL_METHOD; cdecl; TSslMethodV23 = function:PSSL_METHOD; cdecl; + TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl; + TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl; TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; cdecl; + TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl; + TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl; + TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; cdecl; TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PChar):Integer; cdecl; TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl; - TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: Pointer); cdecl; - TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: Pointer); cdecl; + TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl; + TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl; TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; cdecl; TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl; TSslFree = procedure(ssl: PSSL); cdecl; @@ -599,26 +795,43 @@ type TSslPending = function(ssl: PSSL):Integer; cdecl; TSslGetVersion = function(ssl: PSSL):PChar; cdecl; TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl; - TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); cdecl; - TSSLGetCurrentCipher = function(s: PSSL):pointer; cdecl; - TSSLCipherGetName = function(c: pointer):PChar; cdecl; - TSSLCipherGetBits = function(c: pointer; alg_bits: PInteger):Integer; cdecl; + TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl; + TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl; + TSSLCipherGetName = function(c: Sslptr):PChar; cdecl; + TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl; TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl; // libeay.dll - TSslX509Free = procedure(x: PX509); cdecl; - TSslX509NameOneline = function(a: PX509_NAME; buf: PChar; size: Integer):PChar; cdecl; - TSslX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; - TSslX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; - TSslX509NameHash = function(x: PX509_NAME):Cardinal; cdecl; - TSslX509Digest = function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; cdecl; - TSslEvpMd5 = function:PEVP_MD; cdecl; - TErrErrorString = function(e: integer; buf: PChar): PChar; cdecl; + TX509New = function: PX509; cdecl; + TX509Free = procedure(x: PX509); cdecl; + TX509NameOneline = function(a: PX509_NAME; buf: PChar; size: Integer):PChar; cdecl; + TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; + TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; + TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl; + TX509Digest = function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; cdecl; + TX509print = function(b: PBIO; a: PX509): integer; cdecl; + TX509SetVersion = function(x: PX509; version: integer): integer; cdecl; + TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl; + TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl; + TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PChar; _type: integer; + bytes: PChar; len, loc, _set: integer): integer; cdecl; + TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl; + TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl; + TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; + TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; + TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl; + TEvpPkeyNew = function: EVP_PKEY; cdecl; + TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl; + TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl; + TEvpGetDigestByName = function(Name: PChar): PEVP_MD; cdecl; + TEVPcleanup = procedure; cdecl; + TSSLeayversion = function(t: integer): PChar; cdecl; + TErrErrorString = procedure(e: integer; buf: PChar; len: integer); cdecl; TErrGetError = function: integer; cdecl; TErrClearError = procedure; cdecl; TErrFreeStrings = procedure; cdecl; TErrRemoveState = procedure(pid: integer); cdecl; - TEVPcleanup = procedure; cdecl; + TOPENSSLaddallalgorithms = procedure; cdecl; TCRYPTOcleanupAllExData = procedure; cdecl; TRandScreen = procedure; cdecl; TBioNew = function(b: PBIO_METHOD): PBIO; cdecl; @@ -627,12 +840,23 @@ type TBioCtrlPending = function(b: PBIO): integer; cdecl; TBioRead = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl; TBioWrite = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl; - TX509print = function(b: PBIO; a: PX509): integer; cdecl; + Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl; + TPKCS12parse = function(p12: SslPtr; pass: PChar; var pkey, cert, ca: SslPtr): integer; cdecl; + TPKCS12free = procedure(p12: SslPtr); cdecl; + TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl; + TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl; + TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl; + TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl; + Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl; + Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl; + // 3DES functions TDESsetoddparity = procedure(Key: des_cblock); cdecl; TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl; TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl; - + //thread lock functions + TCRYPTOnumlocks = function: integer; cdecl; + TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl; var // libssl.dll @@ -647,7 +871,12 @@ var _SslMethodV3: TSslMethodV3 = nil; _SslMethodTLSV1: TSslMethodTLSV1 = nil; _SslMethodV23: TSslMethodV23 = nil; + _SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil; + _SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil; _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil; + _SslCtxUseCertificate: TSslCtxUseCertificate = nil; + _SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil; + _SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil; _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil; _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil; _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil; @@ -671,19 +900,35 @@ var _SSLGetVerifyResult: TSSLGetVerifyResult = nil; // libeay.dll - _SslX509Free: TSslX509Free = nil; - _SslX509NameOneline: TSslX509NameOneline = nil; - _SslX509GetSubjectName: TSslX509GetSubjectName = nil; - _SslX509GetIssuerName: TSslX509GetIssuerName = nil; - _SslX509NameHash: TSslX509NameHash = nil; - _SslX509Digest: TSslX509Digest = nil; - _SslEvpMd5: TSslEvpMd5 = nil; + _X509New: TX509New = nil; + _X509Free: TX509Free = nil; + _X509NameOneline: TX509NameOneline = nil; + _X509GetSubjectName: TX509GetSubjectName = nil; + _X509GetIssuerName: TX509GetIssuerName = nil; + _X509NameHash: TX509NameHash = nil; + _X509Digest: TX509Digest = nil; + _X509print: TX509print = nil; + _X509SetVersion: TX509SetVersion = nil; + _X509SetPubkey: TX509SetPubkey = nil; + _X509SetIssuerName: TX509SetIssuerName = nil; + _X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil; + _X509Sign: TX509Sign = nil; + _X509GmtimeAdj: TX509GmtimeAdj = nil; + _X509SetNotBefore: TX509SetNotBefore = nil; + _X509SetNotAfter: TX509SetNotAfter = nil; + _X509GetSerialNumber: TX509GetSerialNumber = nil; + _EvpPkeyNew: TEvpPkeyNew = nil; + _EvpPkeyFree: TEvpPkeyFree = nil; + _EvpPkeyAssign: TEvpPkeyAssign = nil; + _EvpGetDigestByName: TEvpGetDigestByName = nil; + _EVPcleanup: TEVPcleanup = nil; + _SSLeayversion: TSSLeayversion = nil; _ErrErrorString: TErrErrorString = nil; _ErrGetError: TErrGetError = nil; _ErrClearError: TErrClearError = nil; _ErrFreeStrings: TErrFreeStrings = nil; _ErrRemoveState: TErrRemoveState = nil; - _EVPcleanup: TEVPcleanup = nil; + _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil; _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil; _RandScreen: TRandScreen = nil; _BioNew: TBioNew = nil; @@ -692,16 +937,31 @@ var _BioCtrlPending: TBioCtrlPending = nil; _BioRead: TBioRead = nil; _BioWrite: TBioWrite = nil; - _X509print: TX509print = nil; + _d2iPKCS12bio: Td2iPKCS12bio = nil; + _PKCS12parse: TPKCS12parse = nil; + _PKCS12free: TPKCS12free = nil; + _RsaGenerateKey: TRsaGenerateKey = nil; + _Asn1UtctimeNew: TAsn1UtctimeNew = nil; + _Asn1UtctimeFree: TAsn1UtctimeFree = nil; + _Asn1IntegerSet: TAsn1IntegerSet = nil; + _i2dX509bio: Ti2dX509bio = nil; + _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil; + // 3DES functions _DESsetoddparity: TDESsetoddparity = nil; _DESsetkeychecked: TDESsetkeychecked = nil; _DESecbencrypt: TDESecbencrypt = nil; + //thread lock functions + _CRYPTOnumlocks: TCRYPTOnumlocks = nil; + _CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil; {$ENDIF} var SSLCS: TCriticalSection; SSLloaded: boolean = false; +{$IFNDEF CIL} + Locks: TList; +{$ENDIF} {$IFNDEF CIL} // libssl.dll @@ -790,6 +1050,22 @@ begin Result := nil; end; +function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUsePrivateKey) then + Result := _SslCtxUsePrivateKey(ctx, pkey) + else + Result := 0; +end; + +function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then + Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(d), len) + else + Result := 0; +end; + //function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; begin @@ -799,6 +1075,30 @@ begin Result := 0; end; +function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificate) then + Result := _SslCtxUseCertificate(ctx, x) + else + Result := 0; +end; + +function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificateASN1) then + Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(d)) + else + Result := 0; +end; + +function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificateFile) then + Result := _SslCtxUseCertificateFile(ctx, PChar(_file), _type) + else + Result := 0; +end; + //function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer; begin @@ -832,7 +1132,7 @@ end; function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: String; const CApath: String):Integer; begin if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then - Result := _SslCtxLoadVerifyLocations(ctx, Pointer(CAfile), Pointer(CApath)) + Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(CAfile), SslPtr(CApath)) else Result := 0; end; @@ -927,7 +1227,7 @@ begin Result := nil; end; -//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); +//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); begin if InitSSLInterface and Assigned(_SslCtxSetVerify) then @@ -945,7 +1245,7 @@ begin Result := nil; end; -//function SSLCipherGetName(c: pointer):PChar; +//function SSLCipherGetName(c: SslPtr):PChar; function SSLCipherGetName(c: SslPtr):String; begin if InitSSLInterface and Assigned(_SSLCipherGetName) then @@ -954,7 +1254,7 @@ begin Result := ''; end; -//function SSLCipherGetBits(c: pointer; alg_bits: PInteger):Integer; +//function SSLCipherGetBits(c: SslPtr; alg_bits: PInteger):Integer; function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; begin if InitSSLInterface and Assigned(_SSLCipherGetBits) then @@ -972,71 +1272,91 @@ begin end; // libeay.dll -procedure SslX509Free(x: PX509); +function X509New: PX509; begin - if InitSSLInterface and Assigned(_SslX509Free) then - _SslX509Free(x); + if InitSSLInterface and Assigned(_X509New) then + Result := _X509New + else + Result := nil; +end; + +procedure X509Free(x: PX509); +begin + if InitSSLInterface and Assigned(_X509Free) then + _X509Free(x); end; //function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; -function SslX509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String; +function X509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String; begin - if InitSSLInterface and Assigned(_SslX509NameOneline) then - Result := _SslX509NameOneline(a, PChar(buf),size) + if InitSSLInterface and Assigned(_X509NameOneline) then + Result := _X509NameOneline(a, PChar(buf),size) else Result := ''; end; -function SslX509GetSubjectName(a: PX509):PX509_NAME; +function X509GetSubjectName(a: PX509):PX509_NAME; begin - if InitSSLInterface and Assigned(_SslX509GetSubjectName) then - Result := _SslX509GetSubjectName(a) + if InitSSLInterface and Assigned(_X509GetSubjectName) then + Result := _X509GetSubjectName(a) else Result := nil; end; -function SslX509GetIssuerName(a: PX509):PX509_NAME; +function X509GetIssuerName(a: PX509):PX509_NAME; begin - if InitSSLInterface and Assigned(_SslX509GetIssuerName) then - Result := _SslX509GetIssuerName(a) + if InitSSLInterface and Assigned(_X509GetIssuerName) then + Result := _X509GetIssuerName(a) else Result := nil; end; -function SslX509NameHash(x: PX509_NAME):Cardinal; +function X509NameHash(x: PX509_NAME):Cardinal; begin - if InitSSLInterface and Assigned(_SslX509NameHash) then - Result := _SslX509NameHash(x) + if InitSSLInterface and Assigned(_X509NameHash) then + Result := _X509NameHash(x) else Result := 0; end; //function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; -function SslX509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer; +function X509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer; begin - if InitSSLInterface and Assigned(_SslX509Digest) then - Result := _SslX509Digest(data, _type, PChar(md), @len) + if InitSSLInterface and Assigned(_X509Digest) then + Result := _X509Digest(data, _type, PChar(md), @len) else Result := 0; end; -function SslEvpMd5:PEVP_MD; +function EvpPkeyNew: EVP_PKEY; begin - if InitSSLInterface and Assigned(_SslEvpMd5) then - Result := _SslEvpMd5 + if InitSSLInterface and Assigned(_EvpPkeyNew) then + Result := _EvpPkeyNew else Result := nil; end; -//function ErrErrorString(e: integer; buf: PChar): PChar; -function ErrErrorString(e: integer; var buf: String): String; +procedure EvpPkeyFree(pk: EVP_PKEY); begin - if InitSSLInterface and Assigned(_ErrErrorString) then - Result := PChar(_ErrErrorString(e, PChar(buf))) + if InitSSLInterface and Assigned(_EvpPkeyFree) then + _EvpPkeyFree(pk); +end; + +function SSLeayversion(t: integer): string; +begin + if InitSSLInterface and Assigned(_SSLeayversion) then + Result := PChar(_SSLeayversion(t)) else Result := ''; end; +procedure ErrErrorString(e: integer; var buf: string; len: integer); +begin + if InitSSLInterface and Assigned(_ErrErrorString) then + _ErrErrorString(e, Pointer(buf), len); + buf := PChar(Buf); +end; + function ErrGetError: integer; begin if InitSSLInterface and Assigned(_ErrGetError) then @@ -1063,6 +1383,12 @@ begin _ErrRemoveState(pid); end; +procedure OPENSSLaddallalgorithms; +begin + if InitSSLInterface and Assigned(_OPENSSLaddallalgorithms) then + _OPENSSLaddallalgorithms; +end; + procedure EVPcleanup; begin if InitSSLInterface and Assigned(_EVPcleanup) then @@ -1137,6 +1463,163 @@ begin Result := 0; end; +function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; +begin + if InitSSLInterface and Assigned(_d2iPKCS12bio) then + Result := _d2iPKCS12bio(b, Pkcs12) + else + Result := nil; +end; + +function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; +begin + if InitSSLInterface and Assigned(_PKCS12parse) then + Result := _PKCS12parse(p12, SslPtr(pass), pkey, cert, ca) + else + Result := 0; +end; + +procedure PKCS12free(p12: SslPtr); +begin + if InitSSLInterface and Assigned(_PKCS12free) then + _PKCS12free(p12); +end; + +function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; +begin + if InitSSLInterface and Assigned(_RsaGenerateKey) then + Result := _RsaGenerateKey(bits, e, callback, cb_arg) + else + Result := nil; +end; + +function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; +begin + if InitSSLInterface and Assigned(_EvpPkeyAssign) then + Result := _EvpPkeyAssign(pkey, _type, key) + else + Result := 0; +end; + +function X509SetVersion(x: PX509; version: integer): integer; +begin + if InitSSLInterface and Assigned(_X509SetVersion) then + Result := _X509SetVersion(x, version) + else + Result := 0; +end; + +function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; +begin + if InitSSLInterface and Assigned(_X509SetPubkey) then + Result := _X509SetPubkey(x, pkey) + else + Result := 0; +end; + +function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; +begin + if InitSSLInterface and Assigned(_X509SetIssuerName) then + Result := _X509SetIssuerName(x, name) + else + Result := 0; +end; + +function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer; + bytes: string; len, loc, _set: integer): integer; +begin + if InitSSLInterface and Assigned(_X509NameAddEntryByTxt) then + Result := _X509NameAddEntryByTxt(name, PChar(field), _type, PChar(Bytes), len, loc, _set) + else + Result := 0; +end; + +function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; +begin + if InitSSLInterface and Assigned(_X509Sign) then + Result := _X509Sign(x, pkey, md) + else + Result := 0; +end; + +function Asn1UtctimeNew: PASN1_UTCTIME; +begin + if InitSSLInterface and Assigned(_Asn1UtctimeNew) then + Result := _Asn1UtctimeNew + else + Result := nil; +end; + +procedure Asn1UtctimeFree(a: PASN1_UTCTIME); +begin + if InitSSLInterface and Assigned(_Asn1UtctimeFree) then + _Asn1UtctimeFree(a); +end; + +function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; +begin + if InitSSLInterface and Assigned(_X509GmtimeAdj) then + Result := _X509GmtimeAdj(s, adj) + else + Result := nil; +end; + +function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; +begin + if InitSSLInterface and Assigned(_X509SetNotBefore) then + Result := _X509SetNotBefore(x, tm) + else + Result := 0; +end; + +function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; +begin + if InitSSLInterface and Assigned(_X509SetNotAfter) then + Result := _X509SetNotAfter(x, tm) + else + Result := 0; +end; + +function i2dX509bio(b: PBIO; x: PX509): integer; +begin + if InitSSLInterface and Assigned(_i2dX509bio) then + Result := _i2dX509bio(b, x) + else + Result := 0; +end; + +function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; +begin + if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then + Result := _i2dPrivateKeyBio(b, pkey) + else + Result := 0; +end; + +function EvpGetDigestByName(Name: String): PEVP_MD; +begin + if InitSSLInterface and Assigned(_EvpGetDigestByName) then + Result := _EvpGetDigestByName(PChar(Name)) + else + Result := nil; +end; + +function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; +begin + if InitSSLInterface and Assigned(_Asn1IntegerSet) then + Result := _Asn1IntegerSet(a, v) + else + Result := 0; +end; + +function X509GetSerialNumber(x: PX509): PASN1_INTEGER; +begin + if InitSSLInterface and Assigned(_X509GetSerialNumber) then + Result := _X509GetSerialNumber(x) + else + Result := nil; +end; + // 3DES functions procedure DESsetoddparity(Key: des_cblock); begin @@ -1157,6 +1640,37 @@ begin if InitSSLInterface and Assigned(_DESecbencrypt) then _DESecbencrypt(Input, output, ks, enc); end; + +procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl; +begin + if (mode and 1) > 0 then + TCriticalSection(Locks[ltype]).Enter + else + TCriticalSection(Locks[ltype]).Leave; +end; + +procedure InitLocks; +var + n: integer; + max: integer; +begin + Locks := TList.Create; + max := _CRYPTOnumlocks; + for n := 1 to max do + Locks.Add(TCriticalSection.Create); + _CRYPTOsetlockingcallback(@locking_callback); +end; + +procedure FreeLocks; +var + n: integer; +begin + _CRYPTOsetlockingcallback(nil); + for n := 0 to Locks.Count - 1 do + TCriticalSection(Locks[n]).Free; + Locks.Free; +end; + {$ENDIF} function LoadLib(const Value: String): HModule; @@ -1211,7 +1725,14 @@ begin _SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method'); _SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method'); _SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method'); - _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_file'); + _SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey'); + _SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1'); + //use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file, + //because SSL_CTX_use_PrivateKey_file not support DER format. :-O + _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file'); + _SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate'); + _SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1'); + _SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_file'); _SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file'); _SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key'); _SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb'); @@ -1234,19 +1755,35 @@ begin _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits'); _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result'); - _SslX509Free := GetProcAddr(SSLUtilHandle, 'X509_free'); - _SslX509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline'); - _SslX509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name'); - _SslX509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name'); - _SslX509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash'); - _SslX509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest'); - _SslEvpMd5 := GetProcAddr(SSLUtilHandle, 'EVP_md5'); - _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string'); + _X509New := GetProcAddr(SSLUtilHandle, 'X509_new'); + _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free'); + _X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline'); + _X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name'); + _X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name'); + _X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash'); + _X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest'); + _X509print := GetProcAddr(SSLUtilHandle, 'X509_print'); + _X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version'); + _X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey'); + _X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name'); + _X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt'); + _X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign'); + _X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj'); + _X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore'); + _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter'); + _X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber'); + _EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new'); + _EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free'); + _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign'); + _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); + _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); + _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version'); + _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings'); _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state'); - _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); + _OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf'); _CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data'); _RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen'); _BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new'); @@ -1255,15 +1792,28 @@ begin _BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending'); _BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read'); _BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write'); - _X509print := GetProcAddr(SSLUtilHandle, 'X509_print'); + _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio'); + _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse'); + _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free'); + _RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key'); + _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new'); + _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free'); + _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set'); + _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio'); + _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio'); + // 3DES functions _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity'); _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked'); _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt'); + // + _CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks'); + _CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback'); {$ENDIF} {$IFDEF CIL} SslLibraryInit; SslLoadErrorStrings; + OPENSSLaddallalgorithms; RandScreen; {$ELSE} SetLength(s, 1024); @@ -1279,8 +1829,12 @@ begin _SslLibraryInit; if assigned(_SslLoadErrorStrings) then _SslLoadErrorStrings; + if assigned(_OPENSSLaddallalgorithms) then + _OPENSSLaddallalgorithms; if assigned(_RandScreen) then _RandScreen; + if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then + InitLocks; {$ENDIF} Result := True; SSLloaded := True; @@ -1320,6 +1874,10 @@ begin if IsSSLLoaded then begin //deinit library +{$IFNDEF CIL} + if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then + FreeLocks; +{$ENDIF} EVPCleanup; CRYPTOcleanupAllExData; ErrRemoveState(0); @@ -1352,7 +1910,12 @@ begin _SslMethodV3 := nil; _SslMethodTLSV1 := nil; _SslMethodV23 := nil; + _SslCtxUsePrivateKey := nil; + _SslCtxUsePrivateKeyASN1 := nil; _SslCtxUsePrivateKeyFile := nil; + _SslCtxUseCertificate := nil; + _SslCtxUseCertificateASN1 := nil; + _SslCtxUseCertificateFile := nil; _SslCtxUseCertificateChainFile := nil; _SslCtxCheckPrivateKeyFile := nil; _SslCtxSetDefaultPasswdCb := nil; @@ -1375,19 +1938,35 @@ begin _SslCipherGetBits := nil; _SslGetVerifyResult := nil; - _SslX509Free := nil; - _SslX509NameOneline := nil; - _SslX509GetSubjectName := nil; - _SslX509GetIssuerName := nil; - _SslX509NameHash := nil; - _SslX509Digest := nil; - _SslEvpMd5 := nil; + _X509New := nil; + _X509Free := nil; + _X509NameOneline := nil; + _X509GetSubjectName := nil; + _X509GetIssuerName := nil; + _X509NameHash := nil; + _X509Digest := nil; + _X509print := nil; + _X509SetVersion := nil; + _X509SetPubkey := nil; + _X509SetIssuerName := nil; + _X509NameAddEntryByTxt := nil; + _X509Sign := nil; + _X509GmtimeAdj := nil; + _X509SetNotBefore := nil; + _X509SetNotAfter := nil; + _X509GetSerialNumber := nil; + _EvpPkeyNew := nil; + _EvpPkeyFree := nil; + _EvpPkeyAssign := nil; + _EVPCleanup := nil; + _EvpGetDigestByName := nil; + _SSLeayversion := nil; _ErrErrorString := nil; _ErrGetError := nil; _ErrClearError := nil; _ErrFreeStrings := nil; _ErrRemoveState := nil; - _EVPCleanup := nil; + _OPENSSLaddallalgorithms := nil; _CRYPTOcleanupAllExData := nil; _RandScreen := nil; _BioNew := nil; @@ -1396,11 +1975,23 @@ begin _BioCtrlPending := nil; _BioRead := nil; _BioWrite := nil; - _X509print := nil; + _d2iPKCS12bio := nil; + _PKCS12parse := nil; + _PKCS12free := nil; + _RsaGenerateKey := nil; + _Asn1UtctimeNew := nil; + _Asn1UtctimeFree := nil; + _Asn1IntegerSet := nil; + _i2dX509bio := nil; + _i2dPrivateKeyBio := nil; + // 3DES functions _DESsetoddparity := nil; _DESsetkeychecked := nil; _DESecbencrypt := nil; + // + _CRYPTOnumlocks := nil; + _CRYPTOsetlockingcallback := nil; {$ENDIF} finally SSLCS.Leave; diff --git a/ssl_streamsec.pas b/ssl_streamsec.pas new file mode 100644 index 0000000..ec54b60 --- /dev/null +++ b/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 | +|==============================================================================| +| 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. + diff --git a/sslinux.pas b/sslinux.pas index d911cb5..536c54f 100644 --- a/sslinux.pas +++ b/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; diff --git a/synachar.pas b/synachar.pas index 06a64df..102fd20 100644 --- a/synachar.pas +++ b/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; + end; + Inc(Index, mb); +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; - mbf, mbt: Byte; - lef, let: Boolean; + TargetTable: array[128..255] of Word; + mbt: Byte; + 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 - ucsstring := Value - else - begin - if not DisableIconv then - cd := SynaIconvOpenIgnore('UCS-2BE', FromID); - try - if cd <> iconv_t(-1) then - SynaIconv(cd, Value, ucsstring) - 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; + if not DisableIconv then + cd := SynaIconvOpenIgnore('UCS-2BE', FromID); + try + if cd <> iconv_t(-1) then + SynaIconv(cd, Value, ucsstring) + else + ucsstring := InternalToUcs(Value, CharFrom); + finally + SynaIconvClose(cd); end; //here we allways have ucstring with UCS-2 encoding //second pass... from UCS-2 to target encoding. diff --git a/synacode.pas b/synacode.pas index da6b719..72e62fd 100644 --- a/synacode.pas +++ b/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]; diff --git a/synaicnv.pas b/synaicnv.pas index 070bc00..de1cc4a 100644 --- a/synaicnv.pas +++ b/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); - Result := Length(inbuf) - ix; + setlength(Outbuf, cardinal(Length(Outbuf)) - ox); + Result := Cardinal(Length(inbuf)) - ix; end else begin @@ -335,7 +340,7 @@ begin Result := IconvLoaded; end; -initialization + initialization begin IconvCS:= TCriticalSection.Create; end; diff --git a/synautil.pas b/synautil.pas index 09c608f..fab0f16 100644 --- a/synautil.pas +++ b/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 n <= Length(Value) do + while Length(Value) > 0 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 := ''; - s := SeparateRight(Value, PairBegin); - x := 1; - for n := 1 to Length(s) do + lenBegin := Length(PairBegin); + lenEnd := Length(PairEnd); + n := Length(Value); + if (Value = PairBegin + PairEnd) then begin - if s[n] = PairBegin then - Inc(x); - if s[n] = PairEnd then + Result := '';//nothing between + exit; + 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; {==============================================================================} - -function UnquoteStr(Value: string; Quote: Char): string; - {$IFNDEF CIL} +// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application! +function UnquoteStr(const Value: string; Quote: Char): string; var - LText: PChar; - {$ENDIF} + n: integer; + 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 - //...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; - {$IFNDEF CIL} - LText := PChar(Value); - Result := AnsiExtractQuotedStr(LText, Quote); - {$ELSE} - Result := DequotedStr(Value, Quote); - {$ENDIF} - if Result = '' then - Result := Value; +end; + +{==============================================================================} + +function QuoteStr(const Value: string; Quote: Char): string; +var + n: integer; +begin + Result := ''; + for n := 1 to length(value) do + begin + Result := result + Value[n]; + 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; diff --git a/tlntsend.pas b/tlntsend.pas index 31a5057..3d18a33 100644 --- a/tlntsend.pas +++ b/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;