diff --git a/SynaSSL.pas b/SynaSSL.pas new file mode 100644 index 0000000..d211f4f --- /dev/null +++ b/SynaSSL.pas @@ -0,0 +1,199 @@ +{==============================================================================| +| Project : Delphree - Synapse | 001.001.001 | +|==============================================================================| +| Content: SSL support | +|==============================================================================| +| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | +| (the "License"); you may not use this file except in compliance with the | +| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| | +| Software distributed under the License is distributed on an "AS IS" basis, | +| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | +| the specific language governing rights and limitations under the License. | +|==============================================================================| +| The Original Code is Synapse Delphi Library. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2002. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +unit SynaSSL; + +interface + +uses +{$IFDEF LINUX} + Libc, SysUtils; +{$ELSE} + Windows; +{$ENDIF} + +const +{$IFDEF LINUX} + DLLSSLName = 'libssl.so'; + DLLUtilName = 'libcrypto.so'; +{$ELSE} + DLLSSLName = 'ssleay32.dll'; + DLLUtilName = 'libeay32.dll'; +{$ENDIF} + +type + PSSL_CTX = Pointer; + PSSL = Pointer; + PSSL_METHOD = Pointer; + PX509 = Pointer; + PX509_NAME = Pointer; + PEVP_MD = Pointer; + PInteger = ^Integer; + +const + EVP_MAX_MD_SIZE = 16+20; + SSL_ERROR_WANT_READ = 2; + SSL_ERROR_WANT_WRITE = 3; + SSL_ERROR_ZERO_RETURN = 6; + +var + SSLLibHandle: Integer = 0; + SSLUtilHandle: Integer = 0; + +// ssleay.dll + SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil; + SslLibraryInit : function:Integer cdecl = nil; + SslLoadErrorStrings : procedure cdecl = nil; + SslCtxSetCipherList : function(arg0: PSSL_CTX; str: PChar):Integer cdecl = nil; + SslCtxNew : function(meth: PSSL_METHOD):PSSL_CTX cdecl = nil; + SslCtxFree : procedure(arg0: PSSL_CTX) cdecl = nil; + SslSetFd : function(s: PSSL; fd: Integer):Integer cdecl = nil; + SslMethodV23 : function:PSSL_METHOD cdecl = nil; + SslCtxUsePrivateKeyFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil; + SslCtxUseCertificateFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil; + SslNew : function(ctx: PSSL_CTX):PSSL cdecl = nil; + SslFree : procedure(ssl: PSSL) cdecl = nil; + SslAccept : function(ssl: PSSL):Integer cdecl = nil; + SslConnect : function(ssl: PSSL):Integer cdecl = nil; + SslShutdown : function(ssl: PSSL):Integer cdecl = nil; + SslRead : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; + SslPeek : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; + SslWrite : function(ssl: PSSL; const buf: PChar; num: Integer):Integer cdecl = nil; + SslGetVersion : function(ssl: PSSL):PChar cdecl = nil; + SslGetPeerCertificate : function(ssl: PSSL):PX509 cdecl = nil; + +// libeay.dll + SslX509Free : procedure(x: PX509) cdecl = nil; + SslX509NameOneline : function(a: PX509_NAME; buf: PChar; size: Integer):PChar cdecl = nil; + SslX509GetSubjectName : function(a: PX509):PX509_NAME cdecl = nil; + SslX509GetIssuerName : function(a: PX509):PX509_NAME cdecl = nil; + SslX509NameHash : function(x: PX509_NAME):Cardinal cdecl = nil; + SslX509Digest : function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer cdecl = nil; + SslEvpMd5 : function:PEVP_MD cdecl = nil; + +function InitSSLInterface: Boolean; +function DestroySSLInterface: Boolean; + +implementation + +uses SyncObjs; + +var + SSLCS: TCriticalSection; + SSLCount: Integer = 0; + +function InitSSLInterface: Boolean; +begin + Result := False; + SSLCS.Enter; + try + if SSLCount = 0 then + begin +{$IFDEF LINUX} + SSLLibHandle := HMODULE(dlopen(DLLSSLName, RTLD_GLOBAL)); + SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL)); +{$ELSE} + SSLLibHandle := LoadLibrary(PChar(DLLSSLName)); + SSLUtilHandle := LoadLibrary(PChar(DLLUtilName)); +{$ENDIF} + if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then + begin + SslGetError := GetProcAddress(SSLLibHandle, PChar('SSL_get_error')); + SslLibraryInit := GetProcAddress(SSLLibHandle, PChar('SSL_library_init')); + SslLoadErrorStrings := GetProcAddress(SSLLibHandle, PChar('SSL_load_error_strings')); + SslCtxSetCipherList := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_cipher_list')); + SslCtxNew := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_new')); + SslCtxFree := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_free')); + SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd')); + SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method')); + SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_file')); + SslCtxUseCertificateFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_certificate_file')); + SslNew := GetProcAddress(SSLLibHandle, PChar('SSL_new')); + SslFree := GetProcAddress(SSLLibHandle, PChar('SSL_free')); + SslAccept := GetProcAddress(SSLLibHandle, PChar('SSL_accept')); + SslConnect := GetProcAddress(SSLLibHandle, PChar('SSL_connect')); + SslShutdown := GetProcAddress(SSLLibHandle, PChar('SSL_shutdown')); + SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read')); + SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek')); + SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write')); + SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate')); + SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version')); + + SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free')); + SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline')); + SslX509GetSubjectName := GetProcAddress(SSLUtilHandle, PChar('X509_get_subject_name')); + SslX509GetIssuerName := GetProcAddress(SSLUtilHandle, PChar('X509_get_issuer_name')); + SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash')); + SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest')); + SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5')); + + Result := True; + end; + end + else Result := True; + if Result then + Inc(SSLCount); + finally + SSLCS.Leave; + end; +end; + +function DestroySSLInterface: Boolean; +begin + SSLCS.Enter; + try + Dec(SSLCount); + if SSLCount < 0 then + SSLCount := 0; + if SSLCount = 0 then + begin + if SSLLibHandle <> 0 then + begin + FreeLibrary(SSLLibHandle); + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin + FreeLibrary(SSLUtilHandle); + SSLLibHandle := 0; + end; + end; + finally + SSLCS.Leave; + end; + Result := True; +end; + +initialization +begin + SSLCS:= TCriticalSection.Create; +end; + +finalization +begin + SSLCS.Free; +end; + +end. diff --git a/blcksock.pas b/blcksock.pas index b2ccf33..13618ee 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 004.004.000 | +| Project : Delphree - Synapse | 005.002.000 | |==============================================================================| | Content: Library base | |==============================================================================| @@ -37,7 +37,7 @@ uses {$ELSE} Windows, WinSock, {$ENDIF} - synsock, SynaUtil; + synsock, SynaUtil, SynaCode, SynaSSL; const cLocalhost = 'localhost'; @@ -115,6 +115,7 @@ type function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; function PeekByte(Timeout: Integer): Byte; virtual; function WaitingData: Integer; + function WaitingDataEx: Integer; procedure SetLinger(Enable: Boolean; Linger: Integer); procedure GetSins; function SockCheck(SockResult: Integer): Integer; @@ -129,6 +130,7 @@ type function GetLocalSinPort: Integer; virtual; function GetRemoteSinPort: Integer; virtual; function CanRead(Timeout: Integer): Boolean; + function CanReadEx(Timeout: Integer): Boolean; function CanWrite(Timeout: Integer): Boolean; function SendBufferTo(Buffer: Pointer; Length: Integer): Integer; virtual; function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; virtual; @@ -175,6 +177,7 @@ type FSocksLocalPort: string; FSocksRemoteIP: string; FSocksRemotePort: string; + FBypassFlag: Boolean; function SocksCode(IP, Port: string): string; function SocksDecode(Value: string): integer; public @@ -193,16 +196,52 @@ type end; TTCPBlockSocket = class(TSocksBlockSocket) + protected + FSslEnabled: Boolean; + FSslBypass: Boolean; + FSsl: PSSL; + Fctx: PSSL_CTX; + FHTTPTunnelIP: string; + FHTTPTunnelPort: string; + FHTTPTunnel: Boolean; + FHTTPTunnelRemoteIP: string; + FHTTPTunnelRemotePort: string; + FHTTPTunnelUser: string; + FHTTPTunnelPass: string; + procedure SetSslEnabled(Value: Boolean); + procedure SocksDoConnect(IP, Port: string); + procedure HTTPTunnelDoConnect(IP, Port: string); public + constructor Create; + destructor Destroy; override; procedure CreateSocket; override; procedure CloseSocket; override; procedure Listen; function Accept: TSocket; procedure Connect(IP, Port: string); override; + procedure SSLDoConnect; + procedure SSLDoShutdown; + function SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean; function GetLocalSinIP: string; override; function GetRemoteSinIP: string; override; function GetLocalSinPort: Integer; override; function GetRemoteSinPort: Integer; override; + function SendBuffer(Buffer: Pointer; Length: Integer): Integer; override; + function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; override; + function SSLGetSSLVersion: string; + function SSLGetPeerSubject: string; + function SSLGetPeerIssuer: string; + function SSLGetPeerSubjectHash: Cardinal; + function SSLGetPeerIssuerHash: Cardinal; + function SSLGetPeerFingerprint: string; + published + property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled; + property SSLBypass: Boolean read FSslBypass write FSslBypass; + property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; + property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; + property HTTPTunnel: Boolean read FHTTPTunnel; + property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser; + property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass; end; TUDPBlockSocket = class(TSocksBlockSocket) @@ -570,8 +609,7 @@ const var x: Integer; s: string; - c: Char; - r,l: Integer; + l: Integer; begin s := ''; l := Length(Terminator); @@ -583,25 +621,9 @@ begin x := 0; if FBuffer = '' then begin - x := WaitingData; - if x > MaxSize then - x := MaxSize; - if x <= 1 then - begin - c := Char(RecvByte(Timeout)); - if FLastError <> 0 then - Break; - FBuffer := c; - end - else - begin - SetLength(FBuffer, x); - r := RecvBuffer(Pointer(FBuffer), x); - if FLastError <> 0 then - Break; - if r < x then - SetLength(FBuffer, r); - end; + FBuffer := RecvPacket(Timeout); + if FLastError <> 0 then + Break; end; s := s + FBuffer; FBuffer := ''; @@ -617,10 +639,7 @@ begin Break; end; until x > 0; - if FLastError = 0 then - Result := s - else - Result := ''; + Result := s; ExceptCheck; end; @@ -691,6 +710,15 @@ begin Result := x; end; +function TBlockSocket.WaitingDataEx: Integer; +begin + if FBuffer <> '' then + Result := Length(FBuffer) + else + Result := WaitingData; +end; + + procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); var li: TLinger; @@ -860,6 +888,14 @@ begin DoStatus(HR_CanWrite, ''); end; +function TBlockSocket.CanReadEx(Timeout: Integer): Boolean; +begin + if FBuffer <> '' then + Result := True + else + Result := CanRead(Timeout); +end; + function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer; var Len: Integer; @@ -1135,6 +1171,7 @@ begin FSocksLocalPort := ''; FSocksRemoteIP := ''; FSocksRemotePort := ''; + FBypassFlag := False; end; function TSocksBlockSocket.SocksOpen: boolean; @@ -1144,38 +1181,43 @@ var begin Result := False; FUsingSocks := False; - if FSocksUsername = '' then - Buf := #5 + #1 + #0 - else - Buf := #5 + #2 + #2 +#0; - SendString(Buf); - Buf := RecvPacket(FSocksTimeout); - FBuffer := Copy(Buf, 3, Length(buf) - 2); - if Length(Buf) < 2 then - Exit; - if Buf[1] <> #5 then - Exit; - n := Ord(Buf[2]); - case n of - 0: //not need authorisation - ; - 2: - begin - Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername - + char(Length(FSocksPassword)) + FSocksPassword; - SendString(Buf); - Buf := RecvPacket(FSocksTimeout); - FBuffer := Copy(Buf, 3, Length(buf) - 2); - if Length(Buf) < 2 then - Exit; - if Buf[2] <> #0 then - Exit; - end; - else - Exit; + FBypassFlag := True; + try + if FSocksUsername = '' then + Buf := #5 + #1 + #0 + else + Buf := #5 + #2 + #2 +#0; + SendString(Buf); + Buf := RecvPacket(FSocksTimeout); + FBuffer := Copy(Buf, 3, Length(buf) - 2); + if Length(Buf) < 2 then + Exit; + if Buf[1] <> #5 then + Exit; + n := Ord(Buf[2]); + case n of + 0: //not need authorisation + ; + 2: + begin + Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername + + char(Length(FSocksPassword)) + FSocksPassword; + SendString(Buf); + Buf := RecvPacket(FSocksTimeout); + FBuffer := Copy(Buf, 3, Length(buf) - 2); + if Length(Buf) < 2 then + Exit; + if Buf[2] <> #0 then + Exit; + end; + else + Exit; + end; + FUsingSocks := True; + Result := True; + finally + FBypassFlag := False; end; - FUsingSocks := True; - Result := True; end; function TSocksBlockSocket.SocksRequest(Cmd: Byte; @@ -1184,9 +1226,14 @@ var Buf: string; begin Result := False; - Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port); - SendString(Buf); - Result := FLastError = 0; + FBypassFlag := True; + try + Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port); + SendString(Buf); + Result := FLastError = 0; + finally + FBypassFlag := False; + end; end; function TSocksBlockSocket.SocksResponse: Boolean; @@ -1195,21 +1242,26 @@ var x: integer; begin Result := False; - FSocksResponseIP := ''; - FSocksResponsePort := ''; - Buf := RecvPacket(FSocksTimeout); - if FLastError <> 0 then - Exit; - if Length(Buf) < 5 then - Exit; - if Buf[1] <> #5 then - Exit; - FSocksLastError := Ord(Buf[2]); - if FSocksLastError <> 0 then - Exit; - x := SocksDecode(Buf); - FBuffer := Copy(Buf, x, Length(buf) - x + 1); - Result := True; + FBypassFlag := True; + try + FSocksResponseIP := ''; + FSocksResponsePort := ''; + Buf := RecvPacket(FSocksTimeout); + if FLastError <> 0 then + Exit; + if Length(Buf) < 5 then + Exit; + if Buf[1] <> #5 then + Exit; + FSocksLastError := Ord(Buf[2]); + if FSocksLastError <> 0 then + Exit; + x := SocksDecode(Buf); + FBuffer := Copy(Buf, x, Length(buf) - x + 1); + Result := True; + finally + FBypassFlag := False; + end; end; function TSocksBlockSocket.SocksCode(IP, Port: string): string; @@ -1407,6 +1459,29 @@ end; {======================================================================} +constructor TTCPBlockSocket.Create; +begin + inherited Create; + FSslEnabled := False; + FSslBypass := False; + FSsl := nil; + Fctx := nil; + FHTTPTunnelIP := ''; + FHTTPTunnelPort := ''; + FHTTPTunnel := False; + FHTTPTunnelRemoteIP := ''; + FHTTPTunnelRemotePort := ''; + FHTTPTunnelUser := ''; + FHTTPTunnelPass := ''; +end; + +destructor TTCPBlockSocket.Destroy; +begin + if FSslEnabled then + SslEnabled := False; + inherited; +end; + procedure TTCPBlockSocket.CreateSocket; begin FSocket := synsock.Socket(PF_INET, Integer(SOCK_STREAM), IPPROTO_TCP); @@ -1478,28 +1553,88 @@ begin end; procedure TTCPBlockSocket.Connect(IP, Port: string); +begin + if FSocksIP <> '' then + SocksDoConnect(IP, Port) + else + if FHTTPTunnelIP <> '' then + HTTPTunnelDoConnect(IP, Port) + else + inherited Connect(IP, Port); + if FSslEnabled then + SSLDoConnect; +end; + +procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); var b: Boolean; begin - if FSocksIP = '' then - inherited Connect(IP, Port) - else - begin - inherited Connect(FSocksIP, FSocksPort); - b := SocksOpen; - if b then - b := SocksRequest(1, IP, Port); - if b then - b := SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSANO_RECOVERY; - FSocksLocalIP := FSocksResponseIP; - FSocksLocalPort := FSocksResponsePort; - FSocksRemoteIP := IP; - FSocksRemotePort := Port; - ExceptCheck; - DoStatus(HR_Connect, IP + ':' + Port); + inherited Connect(FSocksIP, FSocksPort); + b := SocksOpen; + if b then + b := SocksRequest(1, IP, Port); + if b then + b := SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSASYSNOTREADY; + FSocksLocalIP := FSocksResponseIP; + FSocksLocalPort := FSocksResponsePort; + FSocksRemoteIP := IP; + FSocksRemotePort := Port; + ExceptCheck; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); +var + s: string; +begin + try + FBypassFlag := True; + inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); + FHTTPTunnel := False; + SendString('CONNECT ' + IP + ':' + Port + 'HTTP/1.0' + #$0d + #$0a); + if FHTTPTunnelUser <> '' then + Sendstring('Proxy-Authorization: Basic ' + + EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a); + SendString(#$0d + #$0a); + repeat + s := RecvString(30000); + if FLastError <> 0 then + Break; + if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then + FHTTPTunnel := s[10] = '2'; + until s = ''; + if (FLasterror = 0) and not FHTTPTunnel then + FLastError := WSASYSNOTREADY; + FHTTPTunnelRemoteIP := IP; + FHTTPTunnelRemotePort := Port; + finally + FBypassFlag := False; end; + ExceptCheck; +end; + +procedure TTCPBlockSocket.SSLDoConnect; +begin + FLastError := 0; + if not FSSLEnabled then + SSLEnabled := True; + if sslsetfd(FSsl, FSocket) < 0 then + FLastError := WSASYSNOTREADY; + if (FLastError = 0) then + if sslconnect(FSsl) < 0 then + FLastError := WSASYSNOTREADY; + ExceptCheck; +end; + +procedure TTCPBlockSocket.SSLDoShutdown; +begin + FLastError := 0; + if sslshutdown(FSsl) < 0 then + FLastError := WSASYSNOTREADY; + ExceptCheck; + SSLEnabled := False; end; function TTCPBlockSocket.GetLocalSinIP: string; @@ -1515,7 +1650,10 @@ begin if FUsingSocks then Result := FSocksRemoteIP else - Result := inherited GetRemoteSinIP; + if FHTTPTunnel then + Result := FHTTPTunnelRemoteIP + else + Result := inherited GetRemoteSinIP; end; function TTCPBlockSocket.GetLocalSinPort: Integer; @@ -1531,7 +1669,158 @@ begin if FUsingSocks then Result := StrToIntDef(FSocksRemotePort, 0) else - Result := inherited GetRemoteSinPort; + if FHTTPTunnel then + Result := StrToIntDef(FHTTPTunnelRemotePort, 0) + else + Result := inherited GetRemoteSinPort; +end; + +procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean); +begin + if Value <> FSslEnabled then + if Value then + begin + if InitSSLInterface then + begin + SslLoadErrorStrings; + SslLibraryInit; + Fctx := nil; + Fctx := SslCtxNew(SslMethodV23); + Fssl := nil; + Fssl := SslNew(Fctx); + FSslEnabled := True; + end + else DestroySSLInterface; + end + else + begin + sslfree(Fssl); + SslCtxFree(Fctx); + DestroySSLInterface; + FSslEnabled := False; + end; +end; + +function TTCPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; +var + err: integer; +begin + if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then + begin + FLastError := 0; + repeat + Result := SslRead(FSsl, Buffer, Length); + err := SslGetError(FSsl, Result); + until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE); + if err = SSL_ERROR_ZERO_RETURN then + Result := 0 + else + if (err <> 0) then + FLastError := WSASYSNOTREADY; + ExceptCheck; + DoStatus(HR_ReadCount, IntToStr(Result)); + end + else + Result := inherited RecvBuffer(Buffer, Length); +end; + +function TTCPBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; +var + err: integer; +begin + if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then + begin + FLastError := 0; + repeat + Result := SslWrite(FSsl, Buffer, Length); + err := SslGetError(FSsl, Result); + until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE); + if err = SSL_ERROR_ZERO_RETURN then + Result := 0 + else + if (err <> 0) then + FLastError := WSASYSNOTREADY; + ExceptCheck; + DoStatus(HR_WriteCount, IntToStr(Result)); + end + else + Result := inherited SendBuffer(Buffer, Length); +end; + +function TTCPBlockSocket.SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean; +begin + Result := False; + FLastError := 0; + if SslCtxUseCertificateFile(FCtx, PChar(Certificate), 1) < 0 then + FLastError := WSASYSNOTREADY; + if (FLastError = 0) then + if SslCtxUsePrivateKeyFile(FCtx, PChar(PrivateKey), 1) < 0 then + FLastError := WSASYSNOTREADY; + if (FLastError = 0) then + if sslsetfd(FSsl, FSocket) < 0 then + FLastError := WSASYSNOTREADY; + if (FLastError = 0) then + if sslAccept(FSsl) < 0 then + FLastError := WSASYSNOTREADY; + ExceptCheck; + Result := FLastError = 0; +end; + +function TTCPBlockSocket.SSLGetSSLVersion: string; +begin + Result := SSlGetVersion(FSsl); +end; + +function TTCPBlockSocket.SSLGetPeerSubject: string; +var + cert: PX509; + s: string; +begin + cert := SSLGetPeerCertificate(Fssl); + setlength(s, 4096); + Result := SslX509NameOneline(SslX509GetSubjectName(cert), PChar(s), length(s)); + SslX509Free(cert); +end; + +function TTCPBlockSocket.SSLGetPeerIssuer: string; +var + cert: PX509; + s: string; +begin + cert := SSLGetPeerCertificate(Fssl); + setlength(s, 4096); + Result := SslX509NameOneline(SslX509GetIssuerName(cert), PChar(s), length(s)); + SslX509Free(cert); +end; + +function TTCPBlockSocket.SSLGetPeerSubjectHash: Cardinal; +var + cert: PX509; +begin + cert := SSLGetPeerCertificate(Fssl); + Result := SslX509NameHash(SslX509GetSubjectName(cert)); + SslX509Free(cert); +end; + +function TTCPBlockSocket.SSLGetPeerIssuerHash: Cardinal; +var + cert: PX509; +begin + cert := SSLGetPeerCertificate(Fssl); + Result := SslX509NameHash(SslX509GetIssuerName(cert)); + SslX509Free(cert); +end; + +function TTCPBlockSocket.SSLGetPeerFingerprint: string; +var + cert: PX509; + x: integer; +begin + cert := SSLGetPeerCertificate(Fssl); + setlength(Result, EVP_MAX_MD_SIZE); + SslX509Digest(cert, SslEvpMd5, PChar(Result), @x); + SetLength(Result, x); + SslX509Free(cert); end; {======================================================================} diff --git a/ftpsend.pas b/ftpsend.pas index 54cd279..54f7176 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.002.000 | +| Project : Delphree - Synapse | 001.002.002 | |==============================================================================| | Content: FTP client | |==============================================================================| @@ -506,6 +506,8 @@ begin end; function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; +var + x: integer; begin Result := False; FDataStream.Clear; @@ -515,9 +517,11 @@ begin Exit; FTPCommand('TYPE A'); if NameList then - FTPCommand('NLST' + Directory) + x := FTPCommand('NLST' + Directory) else - FTPCommand('LIST' + Directory); + x := FTPCommand('LIST' + Directory); + if (x div 100) <> 1 then + Exit; Result := DataRead(FDataStream); FDataStream.Seek(0, soFromBeginning); end; @@ -638,7 +642,7 @@ end; function TFTPSend.NoOp: Boolean; begin - Result := FTPCommand('NOOP') = 250; + Result := (FTPCommand('NOOP') div 100) = 2; end; function TFTPSend.RenameFile(const OldName, NewName: string): Boolean; diff --git a/httpsend.pas b/httpsend.pas index 113c3e4..c80e8f2 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.000 | +| Project : Delphree - Synapse | 003.000.000 | |==============================================================================| | Content: HTTP client | |==============================================================================| @@ -157,6 +157,7 @@ var Prot, User, Pass, Host, Port, Path, Para, URI: string; n: Integer; s, su: string; + HttpTunnel: Boolean; begin {initial values} Result := False; @@ -164,6 +165,26 @@ begin FResultString := ''; URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); + + if UpperCase(Prot) = 'HTTPS' then + begin + FSock.SSLEnabled := True; + HttpTunnel := FProxyHost <> ''; + FSock.HTTPTunnelIP := FProxyHost; + FSock.HTTPTunnelPort := FProxyPort; + FSock.HTTPTunnelUser := FProxyUser; + FSock.HTTPTunnelPass := FProxyPass; + end + else + begin + FSock.SSLEnabled := False; + HttpTunnel := False; + FSock.HTTPTunnelIP := ''; + FSock.HTTPTunnelPort := ''; + FSock.HTTPTunnelUser := ''; + FSock.HTTPTunnelPass := ''; + end; + Sending := Document.Size > 0; {Headers for Sending data} status100 := Sending and (FProtocol = '1.1'); @@ -178,17 +199,17 @@ begin { setting KeepAlives } if not FKeepAlive then FHeaders.Insert(0, 'Connection: close'); - { set target servers/proxy, authorisations, etc... } + { set target servers/proxy, authorizations, etc... } if User <> '' then FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(user + ':' + pass)); - if (FProxyHost <> '') and (FProxyUser <> '') then + if (FProxyHost <> '') and (FProxyUser <> '') and not(HttpTunnel) then FHeaders.Insert(0, 'Proxy-Authorization: Basic ' + EncodeBase64(FProxyUser + ':' + FProxyPass)); if Port<>'80' then FHeaders.Insert(0, 'Host: ' + Host + ':' + Port) else FHeaders.Insert(0, 'Host: ' + Host); - if FProxyHost <> '' then + if (FProxyHost <> '') and not(HttpTunnel)then URI := Prot + '://' + Host + ':' + Port + URI; if URI = '/*' then URI := '*'; @@ -196,15 +217,15 @@ begin FHeaders.Insert(0, UpperCase(Method) + ' ' + URI) else FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol); - if FProxyHost = '' then - begin - FHTTPHost := Host; - FHTTPPort := Port; - end - else + if (FProxyHost <> '') and not(HttpTunnel) then begin FHTTPHost := FProxyHost; FHTTPPort := FProxyPort; + end + else + begin + FHTTPHost := Host; + FHTTPPort := Port; end; if FHeaders[FHeaders.Count - 1] <> '' then FHeaders.Add(''); diff --git a/mimemess.pas b/mimemess.pas index 83ca7fa..dfab7b4 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.007.000 | +| Project : Delphree - Synapse | 001.007.002 | |==============================================================================| | Content: MIME message object | |==============================================================================| @@ -43,6 +43,7 @@ type FOrganization: string; FCustomHeaders: TStringList; FDate: TDateTime; + FXMailer: string; public constructor Create; destructor Destroy; override; @@ -59,6 +60,7 @@ type property Organization: string read FOrganization Write FOrganization; property CustomHeaders: TStringList read FCustomHeaders; property Date: TDateTime read FDate Write FDate; + property XMailer: string read FXMailer Write FXMailer; end; TMimeMess = class(TObject) @@ -118,28 +120,45 @@ begin FOrganization := ''; FCustomHeaders.Clear; FDate := 0; + FXMailer := ''; end; procedure TMessHeader.EncodeHeaders(const Value: TStringList); var n: Integer; + s: string; begin if FDate = 0 then FDate := Now; for n := FCustomHeaders.Count - 1 downto 0 do if FCustomHeaders[n] <> '' then Value.Insert(0, FCustomHeaders[n]); - Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); + if FXMailer = '' then + Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer') + else + Value.Insert(0, 'x-mailer: ' + FXMailer); Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); if FOrganization <> '' then Value.Insert(0, 'Organization: ' + InlineCode(FOrganization)); + s := ''; for n := 0 to FCCList.Count - 1 do - Value.Insert(0, 'CC: ' + InlineEmail(FCCList[n])); + if s = '' then + s := InlineEmail(FCCList[n]) + else + s := s + ' , ' + InlineEmail(FCCList[n]); + if s <> '' then + Value.Insert(0, 'CC: ' + s); Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); if FSubject <> '' then Value.Insert(0, 'Subject: ' + InlineCode(FSubject)); + s := ''; for n := 0 to FToList.Count - 1 do - Value.Insert(0, 'To: ' + InlineEmail(FToList[n])); + if s = '' then + s := InlineEmail(FToList[n]) + else + s := s + ' , ' + InlineEmail(FToList[n]); + if s <> '' then + Value.Insert(0, 'To: ' + s); Value.Insert(0, 'From: ' + InlineEmail(FFrom)); end; @@ -157,6 +176,11 @@ begin s := NormalizeHeader(Value, x); if s = '' then Break; + if Pos('X-MAILER:', UpperCase(s)) = 1 then + begin + FXMailer := SeparateRight(s, ':'); + continue; + end; if Pos('FROM:', UpperCase(s)) = 1 then begin FFrom := InlineDecode(SeparateRight(s, ':'), cp); diff --git a/mimepart.pas b/mimepart.pas index 407766b..aa93104 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.007.000 | +| Project : Delphree - Synapse | 001.008.001 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| @@ -57,6 +57,7 @@ type FFileName: string; FLines: TStringList; FDecodedLines: TMemoryStream; + FSkipLast: Boolean; procedure SetPrimary(Value: string); procedure SetEncoding(Value: string); procedure SetCharset(Value: string); @@ -85,6 +86,7 @@ type property FileName: string read FFileName Write FFileName; property Lines: TStringList read FLines; property DecodedLines: TMemoryStream read FDecodedLines; + property SkipLast: Boolean read FSkipLast Write FSkipLast; end; const @@ -160,6 +162,7 @@ begin FDecodedLines := TMemoryStream.Create; FTargetCharset := GetCurCP; FDefaultCharset := 'US-ASCII'; + FSkipLast := True; end; destructor TMIMEPart.Destroy; @@ -341,7 +344,10 @@ begin begin s := TrimRight(s); if s = ('--' + b + '--') then - Result := Value.Count - 1; + if FSkipLast then + Result := Value.Count - 1 + else + Result := n + 1; Break; end; end; diff --git a/smtpsend.pas b/smtpsend.pas index dee7dfd..62671a5 100644 --- a/smtpsend.pas +++ b/smtpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.004 | +| Project : Delphree - Synapse | 002.002.000 | |==============================================================================| | Content: SMTP client | |==============================================================================| @@ -455,19 +455,32 @@ function SendToRaw(const MailFrom, MailTo, SMTPHost: string; const MailData: TStrings; const Username, Password: string): Boolean; var SMTP: TSMTPSend; + s, t: string; begin Result := False; SMTP := TSMTPSend.Create; try - SMTP.SMTPHost := SMTPHost; + SMTP.SMTPHost := SeparateLeft(SMTPHost, ':'); + s := SeparateRight(SMTPHost, ':'); + if (s <> '') and (s <> SMTPHost) then + SMTP.SMTPPort := s; SMTP.Username := Username; SMTP.Password := Password; if SMTP.Login then begin - if SMTP.MailFrom(MailFrom, Length(MailData.Text)) then - if SMTP.MailTo(MailTo) then - if SMTP.MailData(MailData) then - Result := True; + if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then + begin + s := MailTo; + repeat + t := GetEmailAddr(fetch(s, ',')); + if t <> '' then + Result := SMTP.MailTo(t); + if not Result then + Break; + until s = ''; + if Result then + Result := SMTP.MailData(MailData); + end; SMTP.Logout; end; finally @@ -484,7 +497,7 @@ begin try t.Assign(MailData); t.Insert(0, ''); - t.Insert(0, 'x-mailer: Synapse - Delphi TCP/IP library by Lukas Gebauer'); + t.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); t.Insert(0, 'subject: ' + Subject); t.Insert(0, 'date: ' + Rfc822DateTime(now)); t.Insert(0, 'to: ' + MailTo); diff --git a/synacode.pas b/synacode.pas index a82473e..015e836 100644 --- a/synacode.pas +++ b/synacode.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.005.002 | +| Project : Delphree - Synapse | 001.005.003 | |==============================================================================| | Content: Coding and decoding support | |==============================================================================| @@ -240,7 +240,9 @@ begin s := Copy(Value, x, 2); Inc(x, 2); if pos(#13, s) + pos(#10, s) = 0 then - Result[l] := Char(StrToIntDef('$' + s, 32)); + Result[l] := Char(StrToIntDef('$' + s, 32)) + else + Result[l] := ' '; end; Inc(l); end; diff --git a/synautil.pas b/synautil.pas index e4007d4..86d1b3f 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.007.001 | +| Project : Delphree - Synapse | 002.008.001 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| @@ -462,23 +462,34 @@ end; function IsIP(const Value: string): Boolean; var - n, x: Integer; + n, x, i: Integer; begin Result := true; - x := 0; - for n := 1 to Length(Value) do - if not (Value[n] in ['0'..'9', '.']) then + if Pos('..',Value) > 0 then + Result := False + else + begin + i := 0; + x := 0; + for n := 1 to Length(Value) do begin - Result := False; - Break; - end - else - begin - if Value[n] = '.' then - Inc(x); + if (Value[n] in ['0'..'9']) then + i := i +1 + else + if (Value[n] in ['.']) then + i := 0 + else + Result := False; + if Value[n] = '.' + then Inc(x); + if i > 3 then + result := False; + if result = false then + Break; end; - if x <> 3 then - Result := False; + if x <> 3 then + Result := False; + end; end; {==============================================================================} @@ -742,6 +753,10 @@ begin end else sURL := URL; + if UpperCase(Prot) = 'HTTPS' then + Port := '443'; + if UpperCase(Prot) = 'FTP' then + Port := '21'; x := Pos('@', sURL); if (x > 0) and (x < Pos('/', sURL)) then begin