pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Bugfixes in OpenSSL, enhanced OpenSSL support, enhanced binary MIME (all by Petr Fejfar)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@147 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2012-03-13 14:46:54 +00:00
parent f5be030c70
commit 3caad66c4b
11 changed files with 600 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
blcksock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 009.008.004 |
| Project : Ararat Synapse | 009.008.005 |
|==============================================================================|
| Content: Library base |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer |
| Copyright (c)1999-2012, 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-2011. |
| Portions created by Lukas Gebauer are Copyright (c)1999-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -81,6 +81,8 @@ Core with implementation basic socket classes.
{$Q-}
{$H+}
{$M+}
{$TYPEDADDRESS OFF}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
@ -1297,6 +1299,9 @@ type
{:Return subject of remote SSL peer.}
function GetPeerSubject: string; virtual;
{:Return Serial number if remote X509 certificate.}
function GetPeerSerialNo: integer; virtual;
{:Return issuer certificate of remote SSL peer.}
function GetPeerIssuer: string; virtual;
@ -1304,6 +1309,10 @@ type
if certificate is generated for remote side IP name.}
function GetPeerName: string; virtual;
{:Returns has of peer name from remote side certificate. This is good
for fast remote side authentication.}
function GetPeerNameHash: cardinal; virtual;
{:Return fingerprint of remote SSL peer.}
function GetPeerFingerprint: string; virtual;
@ -2682,7 +2691,7 @@ end;
function TBlockSocket.ResolveIPToName(IP: string): string;
begin
if not IsIP(IP) or not IsIp6(IP) then
if not IsIP(IP) and not IsIp6(IP) then
IP := ResolveName(IP);
Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
end;
@ -4224,11 +4233,21 @@ begin
Result := '';
end;
function TCustomSSL.GetPeerSerialNo: integer;
begin
Result := -1;
end;
function TCustomSSL.GetPeerName: string;
begin
Result := '';
end;
function TCustomSSL.GetPeerNameHash: cardinal;
begin
Result := 0;
end;
function TCustomSSL.GetPeerIssuer: string;
begin
Result := '';

3
ftpsend.pas
View File

@ -52,6 +52,9 @@ Used RFC: RFC-959, RFC-2228, RFC-2428
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$TYPEINFO ON}// Borland changed defualt Visibility from Public to Published
// and it requires RTTI to be generated $M+
{$M+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}

33
mimemess.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.005.002 |
| Project : Ararat Synapse | 002.006.000 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer |
| Copyright (c)1999-2012, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,8 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -50,6 +51,7 @@ Classes for easy handling with e-mail message.
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$M+}
unit mimemess;
@ -269,6 +271,20 @@ type
{:Decode message from @link(Lines) to @link(MessagePart). Massage headers
are parsed into @link(Header) object.}
procedure DecodeMessage;
{pf}
{: HTTP message is received by @link(THTTPSend) component in two parts:
headers are stored in @link(THTTPSend.Headers) and a body in memory stream
@link(THTTPSend.Document).
On the top of it, HTTP connections are always 8-bit, hence data are
transferred in native format i.e. no transfer encoding is applied.
This method operates the similiar way and produces the same
result as @link(DecodeMessage).
}
procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
{/pf}
published
{:@link(TMimePart) object with decoded MIME message. This object can handle
any number of nested @link(TMimePart) objects itself. It is used for handle
@ -821,4 +837,15 @@ begin
FMessagePart.DecomposeParts;
end;
{pf}
procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
begin
FHeader.Clear;
FLines.Clear;
FLines.Assign(AHeader);
FHeader.DecodeHeaders(FLines);
FMessagePart.DecomposePartsBinary(AHeader,PANSIChar(AData.Memory),PANSIChar(AData.Memory)+AData.Size);
end;
{/pf}
end.

141
mimepart.pas
View File

@ -1,10 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.008.000 |
| Project : Ararat Synapse | 002.009.000 |
|==============================================================================|
| Content: MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| All rights reserved. |
| Copyright (c)1999-200812 |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
@ -33,7 +32,8 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2008. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -54,6 +54,7 @@ Used RFC: RFC-2045
{$H+}
{$Q-}
{$R-}
{$M+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
@ -137,6 +138,7 @@ type
FAttachInside: boolean;
FConvertCharset: Boolean;
FForcedHTMLConvert: Boolean;
FBinaryDecomposer: boolean;
procedure SetPrimary(Value: string);
procedure SetEncoding(Value: string);
procedure SetCharset(Value: string);
@ -204,6 +206,20 @@ type
method @link(GetSubPart)).}
procedure DecomposeParts;
{pf}
{: HTTP message is received by @link(THTTPSend) component in two parts:
headers are stored in @link(THTTPSend.Headers) and a body in memory stream
@link(THTTPSend.Document).
On the top of it, HTTP connections are always 8-bit, hence data are
transferred in native format i.e. no transfer encoding is applied.
This method operates the similiar way and produces the same
result as @link(DecomposeParts).
}
procedure DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar);
{/pf}
{:This part and all subparts is composed into one MIME message stored in
@link(Lines) property.}
procedure ComposeParts;
@ -535,6 +551,7 @@ var
end;
begin
FBinaryDecomposer := false;
x := 0;
Clear;
//extract headers
@ -624,6 +641,95 @@ begin
end;
end;
procedure TMIMEPart.DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar);
var
x: integer;
s: ANSIString;
Mime: TMimePart;
BOP: PANSIChar; // Beginning of Part
EOP: PANSIChar; // End of Part
function ___HasUUCode(ALines:TStrings): boolean;
var
x: integer;
begin
Result := FALSE;
for x:=0 to ALines.Count-1 do
if IsUUcode(ALInes[x]) then
begin
Result := TRUE;
exit;
end;
end;
begin
FBinaryDecomposer := true;
Clear;
// Parse passed headers (THTTPSend returns HTTP headers and body separately)
x := 0;
while x<AHeader.Count do
begin
s := NormalizeHeader(AHeader,x);
if s = '' then
Break;
FHeaders.Add(s);
end;
DecodePartHeader;
// Extract prepart
if FPrimaryCode=MP_MULTIPART then
begin
CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPrePart,FBoundary);
FAttachInside := FAttachInside or ___HasUUCode(FPrePart);
end;
// Extract body part
if FPrimaryCode=MP_MULTIPART then
begin
repeat
if CanSubPart then
begin
Mime := AddSubPart;
BOP := AStx;
EOP := SearchForBoundary(AStx,AEtx,FBoundary);
CopyLinesFromStreamUntilNullLine(BOP,EOP,Mime.Lines);
Mime.DecomposePartsBinary(Mime.Lines,BOP,EOP);
end
else
begin
EOP := SearchForBoundary(AStx,AEtx,FBoundary);
FPartBody.Add(BuildStringFromBuffer(AStx,EOP));
end;
//
BOP := MatchLastBoundary(EOP,AEtx,FBoundary);
if Assigned(BOP) then
begin
AStx := BOP;
Break;
end;
until FALSE;
end;
// Extract nested MIME message
if (FPrimaryCode=MP_MESSAGE) and CanSubPart then
begin
Mime := AddSubPart;
SkipNullLines(AStx,AEtx);
CopyLinesFromStreamUntilNullLine(AStx,AEtx,Mime.Lines);
Mime.DecomposePartsBinary(Mime.Lines,AStx,AEtx);
end
// Extract body of single part
else
begin
FPartBody.Add(BuildStringFromBuffer(AStx,AEtx));
FAttachInside := FAttachInside or ___HasUUCode(FPartBody);
end;
// Extract postpart
if FPrimaryCode=MP_MULTIPART then
begin
CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPostPart,'');
FAttachInside := FAttachInside or ___HasUUCode(FPostPart);
end;
end;
{/pf}
{==============================================================================}
procedure TMIMEPart.ComposeParts;
@ -713,6 +819,33 @@ var
b: Boolean;
begin
FDecodedLines.Clear;
{pf}
// The part decomposer passes data via TStringList which appends trailing line
// break inherently. But in a case of native 8-bit data transferred withouth
// encoding (default e.g. for HTTP protocol), the redundant line terminators
// has to be removed
if FBinaryDecomposer and (FPartBody.Count=1) then
begin
case FEncodingCode of
ME_QUOTED_PRINTABLE:
s := DecodeQuotedPrintable(FPartBody[0]);
ME_BASE64:
s := DecodeBase64(FPartBody[0]);
ME_UU, ME_XX:
begin
s := '';
for n := 0 to FPartBody.Count - 1 do
if FEncodingCode = ME_UU then
s := s + DecodeUU(FPartBody[n])
else
s := s + DecodeXX(FPartBody[n]);
end;
else
s := FPartBody[0];
end;
end
else
{/pf}
case FEncodingCode of
ME_QUOTED_PRINTABLE:
s := DecodeQuotedPrintable(FPartBody.Text);

1
smtpsend.pas
View File

@ -372,7 +372,6 @@ function TSMTPSend.AuthPlain: Boolean;
var
s: ansistring;
begin
Result := False;
s := ansichar(0) + FUsername + ansichar(0) + FPassword;
FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF);
Result := ReadResult = 235;

14
ssl_cryptlib.pas
View File

@ -3,7 +3,7 @@
|==============================================================================|
| Content: SSL/SSH support by Peter Gutmann's CryptLib |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| Copyright (c)1999-2012, 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)2005. |
| Portions created by Lukas Gebauer are Copyright (c)2005-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -84,6 +84,7 @@ unit ssl_cryptlib;
interface
uses
Windows,
SysUtils,
blcksock, synsock, synautil, synacode,
cryptlib;
@ -233,7 +234,6 @@ var
cert: CRYPT_CERTIFICATE;
publicKey: CRYPT_CONTEXT;
begin
Result := False;
if FPrivatekeyFile = '' then
FPrivatekeyFile := GetTempFile('', 'key');
cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
@ -402,7 +402,7 @@ begin
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
FSSLEnabled := False;
if FDelCert then
Deletefile(FPrivatekeyFile);
SysUtils.DeleteFile(FPrivatekeyFile);
end;
function TSSLCryptLib.Prepare(server:Boolean): Boolean;
@ -459,8 +459,8 @@ end;
function TSSLCryptLib.BiShutdown: boolean;
begin
// if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
// cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); //no-op
if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
DeInit;
FReadBuffer := '';
Result := True;
@ -478,8 +478,6 @@ begin
end;
function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
FLastError := 0;
FLastErrorDesc := '';

123
ssl_openssl.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
| Project : Ararat Synapse | 001.002.000 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
@ -33,7 +33,8 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2008. |
| Portions created by Lukas Gebauer are Copyright (c)2005-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -139,10 +140,14 @@ type
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerSerialNo: integer; override; {pf}
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerNameHash: cardinal; override; {pf}
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
@ -331,10 +336,18 @@ begin
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;
try {pf}
if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
if SSLCTXusecertificate(Fctx, cert) > 0 then
if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
Result := True;
{pf}
finally
EvpPkeyFree(pkey);
X509free(cert);
SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated...
end;
{/pf}
finally
PKCS12free(p12);
end;
@ -622,8 +635,11 @@ begin
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;
if (err <> 0) then
Result := 0
{pf}// Verze 1.1.0 byla s else tak jak to ted mam,
// ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN
// propagovano jako Chyba.
{pf} else {/pf} if (err <> 0) then
FLastError := err;
end;
@ -669,6 +685,31 @@ begin
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerSerialNo: integer; {pf}
var
cert: PX509;
SN: PASN1_INTEGER;
begin
if not assigned(FSsl) then
begin
Result := -1;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := -1;
Exit;
end;
SN := X509GetSerialNumber(cert);
Result := Asn1IntegerGet(SN);
finally
X509Free(cert);
end;
end;
function TSSLOpenSSL.GetPeerName: string;
var
s: ansistring;
@ -678,6 +719,28 @@ begin
Result := Trim(SeparateLeft(s, '/'));
end;
function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf}
var
cert: PX509;
begin
if not assigned(FSsl) then
begin
Result := 0;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := 0;
Exit;
end;
Result := X509NameHash(X509GetSubjectName(cert));
finally
X509Free(cert);
end;
end;
function TSSLOpenSSL.GetPeerIssuer: string;
var
cert: PX509;
@ -760,28 +823,34 @@ begin
Result := '';
Exit;
end;
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;
try {pf}
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;
{$ELSE}
setlength(s,x);
y := bioread(b,s,x);
if y > 0 then
setlength(s, y);
{$ENDIF}
Result := ReplaceString(s, LF, CRLF);
{pf}
finally
BioFreeAll(b);
X509Free(cert);
end;
{/pf}
end;
function TSSLOpenSSL.GetCipherName: string;

72
ssl_openssl_lib.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.006.003 |
| Project : Ararat Synapse | 003.007.000 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer |
| Copyright (c)1999-2012, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,8 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2011. |
| Portions created by Lukas Gebauer are Copyright (c)2002-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -143,6 +144,9 @@ type
PASN1_INTEGER = SslPtr;
PPasswdCb = SslPtr;
PFunction = procedure;
PSTACK = SslPtr; {pf}
TSkPopFreeFunc = procedure(p:SslPtr); cdecl; {pf}
TX509Free = procedure(x: PX509); cdecl; {pf}
DES_cblock = array[0..7] of Byte;
PDES_cblock = ^DES_cblock;
@ -770,7 +774,13 @@ var
function Asn1UtctimeNew: PASN1_UTCTIME;
procedure Asn1UtctimeFree(a: PASN1_UTCTIME);
function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer;
function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf}
function i2dX509bio(b: PBIO; x: PX509): integer;
function d2iX509bio(b:PBIO; x:PX509): PX509; {pf}
function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf}
procedure SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); {pf}
function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
// 3DES functions
@ -784,6 +794,9 @@ function IsSSLloaded: Boolean;
function InitSSLInterface: Boolean;
function DestroySSLInterface: Boolean;
var
_X509Free: TX509Free = nil; {pf}
implementation
uses SyncObjs;
@ -836,7 +849,6 @@ type
// libeay.dll
TX509New = function: PX509; cdecl;
TX509Free = procedure(x: PX509); cdecl;
TX509NameOneline = function(a: PX509_NAME; buf: PAnsiChar; size: Integer):PAnsiChar; cdecl;
TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl;
TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl;
@ -880,7 +892,11 @@ type
TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl;
TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl;
TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl;
TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl; {pf}
Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl;
Td2iX509bio = function(b:PBIO; x:PX509): PX509; cdecl; {pf}
TPEMReadBioX509 = function(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl; {pf}
TSkX509PopFree = procedure(st: PSTACK; func: TSkPopFreeFunc); cdecl; {pf}
Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl;
// 3DES functions
@ -936,7 +952,6 @@ var
// libeay.dll
_X509New: TX509New = nil;
_X509Free: TX509Free = nil;
_X509NameOneline: TX509NameOneline = nil;
_X509GetSubjectName: TX509GetSubjectName = nil;
_X509GetIssuerName: TX509GetIssuerName = nil;
@ -979,7 +994,11 @@ var
_Asn1UtctimeNew: TAsn1UtctimeNew = nil;
_Asn1UtctimeFree: TAsn1UtctimeFree = nil;
_Asn1IntegerSet: TAsn1IntegerSet = nil;
_Asn1IntegerGet: TAsn1IntegerGet = nil; {pf}
_i2dX509bio: Ti2dX509bio = nil;
_d2iX509bio: Td2iX509bio = nil; {pf}
_PEMReadBioX509: TPEMReadBioX509 = nil; {pf}
_SkX509PopFree: TSkX509PopFree = nil; {pf}
_i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil;
// 3DES functions
@ -1640,6 +1659,28 @@ begin
Result := 0;
end;
function d2iX509bio(b: PBIO; x: PX509): PX509; {pf}
begin
if InitSSLInterface and Assigned(_d2iX509bio) then
Result := _d2iX509bio(x,b)
else
Result := nil;
end;
function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf}
begin
if InitSSLInterface and Assigned(_PEMReadBioX509) then
Result := _PEMReadBioX509(b,x,callback,cb_arg)
else
Result := nil;
end;
procedure SkX509PopFree(st: PSTACK; func:TSkPopFreeFunc); {pf}
begin
if InitSSLInterface and Assigned(_SkX509PopFree) then
_SkX509PopFree(st,func);
end;
function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
begin
if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then
@ -1664,6 +1705,14 @@ begin
Result := 0;
end;
function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf}
begin
if InitSSLInterface and Assigned(_Asn1IntegerGet) then
Result := _Asn1IntegerGet(a)
else
Result := 0;
end;
function X509GetSerialNumber(x: PX509): PASN1_INTEGER;
begin
if InitSSLInterface and Assigned(_X509GetSerialNumber) then
@ -1748,6 +1797,13 @@ var
s: string;
x: integer;
begin
{pf}
if SSLLoaded then
begin
Result := TRUE;
exit;
end;
{/pf}
SSLCS.Enter;
try
if not IsSSLloaded then
@ -1853,7 +1909,11 @@ begin
_Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new');
_Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free');
_Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set');
_Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get'); {pf}
_i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio');
_d2iX509bio := GetProcAddr(SSLUtilHandle, 'd2i_X509_bio'); {pf}
_PEMReadBioX509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509'); {pf}
_SkX509PopFree := GetProcAddr(SSLUtilHandle, 'SK_X509_POP_FREE'); {pf}
_i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio');
// 3DES functions
@ -2038,6 +2098,8 @@ begin
_Asn1UtctimeNew := nil;
_Asn1UtctimeFree := nil;
_Asn1IntegerSet := nil;
_Asn1IntegerGet := nil; {pf}
_SkX509PopFree := nil; {pf}
_i2dX509bio := nil;
_i2dPrivateKeyBio := nil;

5
synacode.pas
View File

@ -3,7 +3,7 @@
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| Copyright (c)1999-2012, 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-2010. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -49,6 +49,7 @@
{$Q-}
{$R-}
{$H+}
{$TYPEDADDRESS OFF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}

2
synamisc.pas
View File

@ -57,6 +57,8 @@
{$ENDIF}
{$ENDIF}
{$TYPEDADDRESS OFF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}

236
synautil.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 004.014.001 |
| Project : Ararat Synapse | 004.015.000 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| Copyright (c)1999-2012, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,8 +33,9 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2012. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -331,6 +332,34 @@ function XorString(Indata1, Indata2: AnsiString): AnsiString;
is Splitted into multiple lines, then this procedure de-split it into one line.}
function NormalizeHeader(Value: TStrings; var Index: Integer): string;
{pf}
{:Search for one of line terminators CR, LF or NUL. Return position of the
line beginning and length of text.}
procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer);
{:Skip both line terminators CR LF (if any). Move APtr position forward.}
procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar);
{:Skip all blank lines in a buffer starting at APtr and move APtr position forward.}
procedure SkipNullLines (var APtr:PANSIChar; AEtx:PANSIChar);
{:Copy all lines from a buffer starting at APtr to ALines until empty line
or end of the buffer is reached. Move APtr position forward).}
procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings);
{:Copy all lines from a buffer starting at APtr to ALines until ABoundary
or end of the buffer is reached. Move APtr position forward).}
procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString);
{:Search ABoundary in a buffer starting at APtr.
Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).}
function SearchForBoundary (var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
{:Compare a text at position ABOL with ABoundary and return position behind the
match (including a trailing CRLF if any).}
function MatchBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
{:Compare a text at position ABOL with ABoundary + the last boundary suffix
and return position behind the match (including a trailing CRLF if any).}
function MatchLastBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
{:Copy data from a buffer starting at position APtr and delimited by AEtx
position into ANSIString.}
function BuildStringFromBuffer (AStx,AEtx:PANSIChar): ANSIString;
{/pf}
var
{:can be used for your own months strings for @link(getmonthnumber)}
CustomMonthNames: array[1..12] of string;
@ -1823,6 +1852,207 @@ begin
Result := TrimRight(s);
end;
{==============================================================================}
{pf}
procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer);
begin
ABol := APtr;
while (APtr<AEtx) and not (APtr^ in [#0,#10,#13]) do
inc(APtr);
ALength := APtr-ABol;
end;
{/pf}
{pf}
procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar);
begin
if (APtr<AEtx) and (APtr^=#13) then
inc(APtr);
if (APtr<AEtx) and (APtr^=#10) then
inc(APtr);
end;
{/pf}
{pf}
procedure SkipNullLines(var APtr:PANSIChar; AEtx:PANSIChar);
var
bol: PANSIChar;
lng: integer;
begin
while (APtr<AEtx) do
begin
SearchForLineBreak(APtr,AEtx,bol,lng);
SkipLineBreak(APtr,AEtx);
if lng>0 then
begin
APtr := bol;
Break;
end;
end;
end;
{/pf}
{pf}
procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings);
var
bol: PANSIChar;
lng: integer;
s: ANSIString;
begin
// Copying until body separator will be reached
while (APtr<AEtx) and (APtr^<>#0) do
begin
SearchForLineBreak(APtr,AEtx,bol,lng);
SkipLineBreak(APtr,AEtx);
if lng=0 then
Break;
SetString(s,bol,lng);
ALines.Add(s);
end;
end;
{/pf}
{pf}
procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString);
var
bol: PANSIChar;
lng: integer;
s: ANSIString;
BackStop: ANSIString;
eob1: PANSIChar;
eob2: PANSIChar;
begin
BackStop := '--'+ABoundary;
eob2 := nil;
// Copying until Boundary will be reached
while (APtr<AEtx) do
begin
SearchForLineBreak(APtr,AEtx,bol,lng);
SkipLineBreak(APtr,AEtx);
eob1 := MatchBoundary(bol,APtr,ABoundary);
if Assigned(eob1) then
eob2 := MatchLastBoundary(bol,AEtx,ABoundary);
if Assigned(eob2) then
begin
APtr := eob2;
Break;
end
else if Assigned(eob1) then
begin
APtr := eob1;
Break;
end
else
begin
SetString(s,bol,lng);
ALines.Add(s);
end;
end;
end;
{/pf}
{pf}
function SearchForBoundary(var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
var
eob: PANSIChar;
Step: integer;
begin
Result := nil;
// Moving Aptr position forward until boundary will be reached
while (APtr<AEtx) do
begin
if strlcomp(APtr,#13#10'--',4)=0 then
begin
eob := MatchBoundary(APtr,AEtx,ABoundary);
Step := 4;
end
else if strlcomp(APtr,'--',2)=0 then
begin
eob := MatchBoundary(APtr,AEtx,ABoundary);
Step := 2;
end
else
begin
eob := nil;
Step := 1;
end;
if Assigned(eob) then
begin
Result := APtr; // boundary beginning
APtr := eob; // boundary end
exit;
end
else
inc(APtr,Step);
end;
end;
{/pf}
{pf}
function MatchBoundary(ABol,AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
var
MatchPos: PANSIChar;
Lng: integer;
begin
Result := nil;
MatchPos := ABol;
Lng := length(ABoundary);
if (MatchPos+2+Lng)>AETX then
exit;
if strlcomp(MatchPos,#13#10,2)=0 then
inc(MatchPos,2);
if (MatchPos+2+Lng)>AETX then
exit;
if strlcomp(MatchPos,'--',2)<>0 then
exit;
inc(MatchPos,2);
if strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then
exit;
inc(MatchPos,Lng);
if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
inc(MatchPos,2);
Result := MatchPos;
end;
{/pf}
{pf}
function MatchLastBoundary(ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
var
MatchPos: PANSIChar;
begin
Result := nil;
MatchPos := MatchBoundary(ABOL,AETX,ABoundary);
if not Assigned(MatchPos) then
exit;
if strlcomp(MatchPos,'--',2)<>0 then
exit;
inc(MatchPos,2);
if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
inc(MatchPos,2);
Result := MatchPos;
end;
{/pf}
{pf}
function BuildStringFromBuffer(AStx,AEtx:PANSIChar): ANSIString;
var
lng: integer;
begin
Lng := 0;
if Assigned(AStx) and Assigned(AEtx) then
begin
Lng := AEtx-AStx;
if Lng<0 then
Lng := 0;
end;
SetString(Result,AStx,lng);
end;
{/pf}
{==============================================================================}
var
n: integer;