pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 27

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@57 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:13:22 +00:00
parent 47b69e0a35
commit a186c48b78
9 changed files with 712 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

199
SynaSSL.pas Normal file
View File

@ -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.

481
blcksock.pas
View File

@ -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;
{======================================================================}

12
ftpsend.pas
View File

@ -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;

41
httpsend.pas
View File

@ -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('');

32
mimemess.pas
View File

@ -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);

10
mimepart.pas
View File

@ -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;

27
smtpsend.pas
View File

@ -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);

6
synacode.pas
View File

@ -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;

43
synautil.pas
View File

@ -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