pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 36

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@78 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:39:12 +00:00
parent 042bebc823
commit a96a758414
26 changed files with 3565 additions and 1406 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
asn1util.pas
View File

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

1202
blcksock.pas
View File

File diff suppressed because it is too large Load Diff

5
dnssend.pas
View File

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

98
ftpsend.pas
View File

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

80
httpsend.pas
View File

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

50
imapsend.pas
View File

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

57
ldapsend.pas
View File

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

4
mimeinln.pas
View File

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

36
mimemess.pas
View File

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

174
mimepart.pas
View File

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

57
nntpsend.pas
View File

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

56
pop3send.pas
View File

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

10
slogsend.pas
View File

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

70
smtpsend.pas
View File

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

3
snmpsend.pas
View File

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

4
sntpsend.pas
View File

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

535
ssl_cryptlib.pas Normal file
View File

@ -0,0 +1,535 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.002 |
|==============================================================================|
| Content: SSL/SSH support by Peter Gutmann's CryptLib |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL/SSH plugin for CryptLib)
This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32
and Linux. This library is staticly linked - when you compile your application
with this plugin, you MUST distribute it with Cryptib library, otherwise you
cannot run your application!
It can work with keys and certificates stored as PKCS#15 only! It must be stored
as disk file only, you cannot load them from memory! Each file can hold multiple
keys and certificates. You must identify it by 'label' stored in
@link(TSSLCryptLib.PrivateKeyLabel).
If you need to use secure connection and authorize self by certificate
(each SSL/TLS server or client with client authorization), then use
@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and
@link(TCustomSSL.KeyPassword) properties.
If you need to use server what verifying client certificates, then use
@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients
with non-matching certificates will be rejected by cryptLib.
This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
server without explicitly assigned key and certificate, then this plugin create
Ad-Hoc key and certificate for each incomming connection by self. It slowdown
accepting of new connections!
You can use this plugin for SSHv2 connections too! You must explicitly set
@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username)
and @link(TCustomSSL.password). You can use special SSH channels too, see
@link(TCustomSSL).
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_cryptlib;
interface
uses
SysUtils,
blcksock, synsock, synautil, synacode,
cryptlib;
type
{:@abstract(class implementing CryptLib SSL/SSH plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLCryptLib = class(TCustomSSL)
protected
FCryptSession: CRYPT_SESSION;
FPrivateKeyLabel: string;
FDelCert: Boolean;
function SSLCheck(Value: integer): Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
function CreateSelfSignedCert(Host: string): Boolean; override;
public
{:See @inherited}
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited}
procedure Assign(const Value: TCustomSSL); override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
published
{:name of certificate/key within PKCS#15 file. It can hold more then one
certificate/key and each certificate/key must have unique label within one file.}
property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
end;
implementation
{==============================================================================}
constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
FPrivateKeyLabel := 'synapse';
FDelCert := false;
end;
destructor TSSLCryptLib.Destroy;
begin
DeInit;
inherited Destroy;
end;
procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
begin
inherited Assign(Value);
if Value is TSSLCryptLib then
begin
FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
end;
end;
function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
var
l: integer;
begin
l := 0;
cryptGetAttributeString(cryptHandle, attributeType, nil, l);
setlength(Result, l);
cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
setlength(Result, l);
end;
function TSSLCryptLib.LibVersion: String;
var
x: integer;
begin
Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
Result := Result + ' v' + IntToStr(x);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
Result := Result + '.' + IntToStr(x);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
Result := Result + '.' + IntToStr(x);
end;
function TSSLCryptLib.LibName: String;
begin
Result := 'ssl_cryptlib';
end;
function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
begin
Result := true;
FLastErrorDesc := '';
FLastError := Value;
if FLastError <> 0 then
begin
Result := False;
FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
end;
end;
function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
var
privateKey: CRYPT_CONTEXT;
keyset: CRYPT_KEYSET;
cert: CRYPT_CERTIFICATE;
publicKey: CRYPT_CONTEXT;
begin
Result := False;
if FPrivatekeyFile = '' then
FPrivatekeyFile := GetTempFile('', 'key');
cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
Length(FPrivatekeyLabel));
cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
cryptGenerateKey(privateKey);
cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
FDelCert := True;
cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
cryptSignCert(cert, privateKey);
cryptAddPublicKey(keyset, cert);
cryptKeysetClose(keyset);
cryptDestroyCert(cert);
cryptDestroyContext(privateKey);
cryptDestroyContext(publicKey);
Result := True;
end;
function TSSLCryptLib.Init(server:Boolean): Boolean;
var
st: CRYPT_SESSION_TYPE;
keysetobj: CRYPT_KEYSET;
cryptContext: CRYPT_CONTEXT;
x: integer;
begin
Result := False;
FLastErrorDesc := '';
FLastError := 0;
FDelCert := false;
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
if server then
case FSSLType of
LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
st := CRYPT_SESSION_SSL_SERVER;
LT_SSHv2:
st := CRYPT_SESSION_SSH_SERVER;
else
Exit;
end
else
case FSSLType of
LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
st := CRYPT_SESSION_SSL;
LT_SSHv2:
st := CRYPT_SESSION_SSH;
else
Exit;
end;
if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
Exit;
x := -1;
case FSSLType of
LT_SSLv3:
x := 0;
LT_TLSv1:
x := 1;
LT_TLSv1_1:
x := 2;
end;
if x >= 0 then
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
Exit;
if FUsername <> '' then
begin
cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
Pointer(FUsername), Length(FUsername));
cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
Pointer(FPassword), Length(FPassword));
end;
if FSSLType = LT_SSHv2 then
if FSSHChannelType <> '' then
begin
cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
Pointer(FSSHChannelType), Length(FSSHChannelType));
if FSSHChannelArg1 <> '' then
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
if FSSHChannelArg2 <> '' then
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
end;
if server and (FPrivatekeyFile = '') then
begin
if FPrivatekeyLabel = '' then
FPrivatekeyLabel := 'synapse';
if FkeyPassword = '' then
FkeyPassword := 'synapse';
CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
end;
if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
begin
if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
Exit;
try
if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
Exit;
if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
cryptcontext)) then
Exit;
finally
cryptKeysetClose(keySetObj);
cryptDestroyContext(cryptcontext);
end;
end;
if server and FVerifyCert then
begin
if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
Exit;
try
if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
keySetObj)) then
Exit;
finally
cryptKeysetClose(keySetObj);
end;
end;
Result := true;
end;
function TSSLCryptLib.DeInit: Boolean;
begin
Result := True;
if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
CryptDestroySession(FcryptSession);
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
FSSLEnabled := False;
if FDelCert then
Deletefile(FPrivatekeyFile);
end;
function TSSLCryptLib.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLCryptLib.Connect: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(false) then
begin
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
Exit;
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLCryptLib.Accept: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(true) then
begin
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
Exit;
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLCryptLib.Shutdown: boolean;
begin
Result := BiShutdown;
end;
function TSSLCryptLib.BiShutdown: boolean;
begin
if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
DeInit;
Result := True;
end;
function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
FLastError := 0;
FLastErrorDesc := '';
SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
cryptFlushData(FcryptSession);
Result := l;
end;
function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
FLastError := 0;
FLastErrorDesc := '';
SSLCheck(cryptPopData(FCryptSession, Buffer, Len, L));
Result := l;
end;
function TSSLCryptLib.WaitingData: Integer;
begin
Result := 0;
end;
function TSSLCryptLib.GetSSLVersion: string;
var
x: integer;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
case x of
0:
Result := 'SSLv3';
1:
Result := 'TLSv1';
2:
Result := 'TLSv1.1';
end;
if FSSLType in [LT_SSHv2] then
case x of
0:
Result := 'SSHv1';
1:
Result := 'SSHv2';
end;
end;
function TSSLCryptLib.GetPeerSubject: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED);
Result := GetString(cert, CRYPT_CERTINFO_DN);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerName: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerIssuer: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
Result := GetString(cert, CRYPT_CERTINFO_DN);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerFingerprint: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
Result := MD5(Result);
cryptDestroyCert(cert);
end;
{==============================================================================}
initialization
if cryptInit = CRYPT_OK then
SSLImplementation := TSSLCryptLib;
cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
finalization
cryptEnd;
end.

796
ssl_openssl.pas Normal file
View File

@ -0,0 +1,796 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.003 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//requires OpenSSL libraries!
{:@abstract(SSL plugin for OpenSSL)
You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but
application mysteriously crashing when you are using freePascal on Linux.
Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see
any problems with FreePascal.
OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you
compile your application with this unit. SSL just not working when you not have
OpenSSL libraries.
This plugin have limited support for .NET too! Because is not possible to use
callbacks with CDECL calling convention under .NET, is not supported
key/certificate passwords and multithread locking. :-(
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br
@link(TCustomSSL.Certificate) for ASN1 DER format only. @br
@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br
@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br
@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br
@link(TCustomSSL.PFXFile) for PFX format. @br
@link(TCustomSSL.PFX) for PFX format from binary string. @br
This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
server without explicitly assigned key and certificate, then this plugin create
Ad-Hoc key and certificate for each incomming connection by self. It slowdown
accepting of new connections!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_openssl;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil,
{$IFDEF CIL}
System.Text,
{$ENDIF}
ssl_openssl_lib;
type
{:@abstract(class implementing OpenSSL SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLOpenSSL = class(TCustomSSL)
protected
FSsl: PSSL;
Fctx: PSSL_CTX;
function SSLCheck: Boolean;
function SetSslKeys: boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
function LoadPFX(pfxdata: string): Boolean;
function CreateSelfSignedCert(Host: string): Boolean; override;
public
{:See @inherited}
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
{:See @inherited}
function GetCipherName: string; override;
{:See @inherited}
function GetCipherBits: integer; override;
{:See @inherited}
function GetCipherAlgBits: integer; override;
{:See @inherited}
function GetVerifyCert: integer; override;
end;
implementation
{==============================================================================}
{$IFNDEF CIL}
function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
var
Password: String;
begin
Password := '';
if TCustomSSL(userdata) is TCustomSSL then
Password := TCustomSSL(userdata).KeyPassword;
if Length(Password) > (Size - 1) then
SetLength(Password, Size - 1);
Result := Length(Password);
StrLCopy(buf, PChar(Password + #0), Result + 1);
end;
{$ENDIF}
{==============================================================================}
constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FCiphers := 'DEFAULT';
FSsl := nil;
Fctx := nil;
end;
destructor TSSLOpenSSL.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLOpenSSL.LibVersion: String;
begin
Result := SSLeayversion(0);
end;
function TSSLOpenSSL.LibName: String;
begin
Result := 'ssl_openssl';
end;
function TSSLOpenSSL.SSLCheck: Boolean;
{$IFDEF CIL}
var
sb: StringBuilder;
{$ENDIF}
begin
Result := true;
FLastErrorDesc := '';
FLastError := ErrGetError;
ErrClearError;
if FLastError <> 0 then
begin
Result := False;
{$IFDEF CIL}
sb := StringBuilder.Create(256);
ErrErrorString(FLastError, sb, 256);
FLastErrorDesc := Trim(sb.ToString);
{$ELSE}
FLastErrorDesc := StringOfChar(#0, 256);
ErrErrorString(FLastError, FLastErrorDesc, Length(FLastErrorDesc));
{$ENDIF}
end;
end;
function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean;
var
pk: EVP_PKEY;
x: PX509;
rsa: PRSA;
t: PASN1_UTCTIME;
name: PX509_NAME;
b: PBIO;
xn, y: integer;
s: AnsiString;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
Result := True;
pk := EvpPkeynew;
x := X509New;
try
rsa := RsaGenerateKey(1024, $10001, nil, nil);
EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
X509SetVersion(x, 2);
Asn1IntegerSet(X509getSerialNumber(x), 0);
t := Asn1UtctimeNew;
try
X509GmtimeAdj(t, -60 * 60 *24);
X509SetNotBefore(x, t);
X509GmtimeAdj(t, 60 * 60 * 60 *24);
X509SetNotAfter(x, t);
finally
Asn1UtctimeFree(t);
end;
X509SetPubkey(x, pk);
Name := X509GetSubjectName(x);
X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0);
X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0);
x509SetIssuerName(x, Name);
x509Sign(x, pk, EvpGetDigestByName('SHA1'));
b := BioNew(BioSMem);
try
i2dX509Bio(b, x);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FCertificate := s;
b := BioNew(BioSMem);
try
i2dPrivatekeyBio(b, pk);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FPrivatekey := s;
finally
X509free(x);
EvpPkeyFree(pk);
end;
end;
function TSSLOpenSSL.LoadPFX(pfxdata: string): Boolean;
var
cert, pkey, ca: SslPtr;
b: PBIO;
p12: SslPtr;
begin
Result := False;
b := BioNew(BioSMem);
try
BioWrite(b, pfxdata, Length(PfxData));
p12 := d2iPKCS12bio(b, nil);
if not Assigned(p12) then
Exit;
try
cert := nil;
pkey := nil;
ca := nil;
if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
if SSLCTXusecertificate(Fctx, cert) > 0 then
if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
Result := True;
finally
PKCS12free(p12);
end;
finally
BioFreeAll(b);
end;
end;
function TSSLOpenSSL.SetSslKeys: boolean;
var
st: TFileStream;
s: string;
begin
Result := False;
if not assigned(FCtx) then
Exit;
try
if FCertificateFile <> '' then
if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then
Exit;
if FCertificate <> '' then
if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then
Exit;
SSLCheck;
if FPrivateKeyFile <> '' then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then
Exit;
if FPrivateKey <> '' then
if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then
Exit;
SSLCheck;
if FCertCAFile <> '' then
if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then
Exit;
if FPFXfile <> '' then
begin
try
st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone);
try
s := ReadStrFromStream(st, st.Size);
finally
st.Free;
end;
if not LoadPFX(s) then
Exit;
except
on Exception do
Exit;
end;
end;
if FPFX <> '' then
if not LoadPFX(FPfx) then
Exit;
SSLCheck;
Result := True;
finally
SSLCheck;
end;
end;
function TSSLOpenSSL.Init(server:Boolean): Boolean;
begin
Result := False;
FLastErrorDesc := '';
FLastError := 0;
Fctx := nil;
case FSSLType of
LT_SSLv2:
Fctx := SslCtxNew(SslMethodV2);
LT_SSLv3:
Fctx := SslCtxNew(SslMethodV3);
LT_TLSv1:
Fctx := SslCtxNew(SslMethodTLSV1);
LT_all:
Fctx := SslCtxNew(SslMethodV23);
else
Exit;
end;
if Fctx = nil then
begin
SSLCheck;
Exit;
end
else
begin
SslCtxSetCipherList(Fctx, FCiphers);
if FVerifyCert then
SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
else
SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
{$IFNDEF CIL}
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
{$ENDIF}
if server and (FCertificateFile = '') and (FCertificate = '')
and (FPFXfile = '') and (FPFX = '') then
begin
CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
end;
if not SetSSLKeys then
Exit
else
begin
Fssl := nil;
Fssl := SslNew(Fctx);
if Fssl = nil then
begin
SSLCheck;
exit;
end;
end;
end;
Result := true;
end;
function TSSLOpenSSL.DeInit: Boolean;
begin
Result := True;
if assigned (Fssl) then
sslfree(Fssl);
Fssl := nil;
if assigned (Fctx) then
begin
SslCtxFree(Fctx);
Fctx := nil;
ErrRemoveState(0);
end;
FSSLEnabled := False;
end;
function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLOpenSSL.Connect: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(False) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
x := sslconnect(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
if FverifyCert then
if GetVerifyCert <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Accept: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(True) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
x := sslAccept(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Shutdown: boolean;
begin
if assigned(FSsl) then
sslshutdown(FSsl);
DeInit;
Result := True;
end;
function TSSLOpenSSL.BiShutdown: boolean;
var
x: integer;
begin
if assigned(FSsl) then
begin
x := sslshutdown(FSsl);
if x = 0 then
begin
Synsock.Shutdown(FSocket.Socket, 1);
sslshutdown(FSsl);
end;
end;
DeInit;
Result := True;
end;
function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
s := StringOf(Buffer);
Result := SslWrite(FSsl, s, Len);
{$ELSE}
Result := SslWrite(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0
else
if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
sb: stringbuilder;
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
sb := StringBuilder.Create(Len);
Result := SslRead(FSsl, sb, Len);
if Result > 0 then
begin
sb.Length := Result;
s := sb.ToString;
System.Array.Copy(BytesOf(s), Buffer, length(s));
end;
{$ELSE}
Result := SslRead(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0
else
if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.WaitingData: Integer;
begin
Result := sslpending(Fssl);
end;
function TSSLOpenSSL.GetSSLVersion: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SSlGetVersion(FSsl);
end;
function TSSLOpenSSL.GetPeerSubject: string;
var
cert: PX509;
s: string;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerName: string;
var
s: string;
begin
s := GetPeerSubject;
s := SeparateRight(s, '/CN=');
Result := Trim(SeparateLeft(s, '/'));
end;
function TSSLOpenSSL.GetPeerIssuer: string;
var
cert: PX509;
s: string;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerFingerprint: string;
var
cert: PX509;
x: integer;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
{$IFDEF CIL}
sb := StringBuilder.Create(EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), sb, x);
sb.Length := x;
Result := sb.ToString;
{$ELSE}
setlength(Result, EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), Result, x);
SetLength(Result, x);
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetCertInfo: string;
var
cert: PX509;
x, y: integer;
b: PBIO;
s: AnsiString;
{$IFDEF CIL}
sb: stringbuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
b := BioNew(BioSMem);
try
X509Print(b, cert);
x := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(x);
y := bioread(b, sb, x);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s,x);
y := bioread(b,s,x);
if y > 0 then
setlength(s, y);
{$ENDIF}
Result := ReplaceString(s, LF, CRLF);
finally
BioFreeAll(b);
end;
end;
function TSSLOpenSSL.GetCipherName: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SslCipherGetName(SslGetCurrentCipher(FSsl));
end;
function TSSLOpenSSL.GetCipherBits: integer;
var
x: integer;
begin
if not assigned(FSsl) then
Result := 0
else
Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x);
end;
function TSSLOpenSSL.GetCipherAlgBits: integer;
begin
if not assigned(FSsl) then
Result := 0
else
SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result);
end;
function TSSLOpenSSL.GetVerifyCert: integer;
begin
if not assigned(FSsl) then
Result := 1
else
Result := SslGetVerifyResult(FSsl);
end;
{==============================================================================}
initialization
if InitSSLInterface then
SSLImplementation := TSSLOpenSSL;
end.

809
synassl.pas → ssl_openssl_lib.pas
View File

File diff suppressed because it is too large Load Diff

528
ssl_streamsec.pas Normal file
View File

@ -0,0 +1,528 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.005 |
|==============================================================================|
| Content: SSL support by StreamSecII |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Henrick Hellström <henrick@streamsec.se> |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
StreamSecII is native pascal library, you not need any external libraries!
You can tune lot of StreamSecII properties by using your GlobalServer. If you not
using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
instance for each TCP connection. Formore information about GlobalServer usage
refer StreamSecII documentation.
If you are not using key and certificate by GlobalServer, then you can use
properties of this plugin instead, but this have limited features and
@link(TCustomSSL.KeyPassword) not working properly yet!
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
of keys and certificates refer to StreamSecII documentation.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_streamsec;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil, synacode,
TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
SecUtils;
type
{:@exclude}
TMyTLSSynSockSlave = class(TTLSSynSockSlave)
protected
procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
function GetMyTLSServer: TCustomTLSInternalServer;
published
property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer;
end;
{:@abstract(class implementing StreamSecII SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLStreamSec = class(TCustomSSL)
protected
FSlave: TMyTLSSynSockSlave;
FIsServer: Boolean;
FTLSServer: TCustomTLSInternalServer;
function SSLCheck: Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
function X500StrToStr(const Prefix: string; const Value: TX500String): string;
function X501NameToStr(const Value: TX501Name): string;
function GetCert: PASN1Struct;
public
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
published
{:TLS server for tuning of StreamSecII.}
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
end;
implementation
{==============================================================================}
procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
begin
TLSServer := Value;
end;
function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
begin
Result := TLSServer;
end;
{==============================================================================}
constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FSlave := nil;
FIsServer := False;
FTLSServer := nil;
end;
destructor TSSLStreamSec.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLStreamSec.LibVersion: String;
begin
Result := 'StreamSecII';
end;
function TSSLStreamSec.LibName: String;
begin
Result := 'ssl_streamsec';
end;
function TSSLStreamSec.SSLCheck: Boolean;
begin
Result := true;
FLastErrorDesc := '';
if not Assigned(FSlave) then
Exit;
FLastError := FSlave.ErrorCode;
if FLastError <> 0 then
begin
FLastErrorDesc := TlsConst.AlertMsg(FLastError);
end;
end;
procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
begin
ExplicitTrust := true;
end;
function TSSLStreamSec.Init(server:Boolean): Boolean;
var
st: TMemoryStream;
pass: TSecretKey;
ws: WideString;
begin
Result := False;
ws := FKeyPassword;
pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
try
FIsServer := Server;
FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
if Assigned(FTLSServer) then
FSlave.MyTLSServer := FTLSServer
else
if Assigned(TLSInternalServer.GlobalServer) then
FSlave.MyTLSServer := TLSInternalServer.GlobalServer
else
FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
if server then
FSlave.MyTLSServer.ClientOrServer := cosServerSide
else
FSlave.MyTLSServer.ClientOrServer := cosClientSide;
if not FVerifyCert then
begin
FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
end;
FSlave.MyTLSServer.Options.VerifyServerName := [];
FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
FSlave.MyTLSServer.Options.RequestClientCertificate := False;
FSlave.MyTLSServer.Options.RequireClientCertificate := False;
if server and FVerifyCert then
begin
FSlave.MyTLSServer.Options.RequestClientCertificate := True;
FSlave.MyTLSServer.Options.RequireClientCertificate := True;
end;
if FCertCAFile <> '' then
FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
if FCertCA <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertCA);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadRootCertsFromStream(st);
finally
st.free;
end;
end;
if FTrustCertificateFile <> '' then
FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
if FTrustCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FTrustCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
finally
st.free;
end;
end;
if FPrivateKeyFile <> '' then
FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
if FPrivateKey <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FPrivateKey);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
finally
st.free;
end;
end;
if FCertificateFile <> '' then
FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
if FCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadMyCertsFromStream(st);
finally
st.free;
end;
end;
if FPFXfile <> '' then
FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
if server then
begin
FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
FSlave.MyTLSServer.TLSSetupServer;
end;
Result := true;
finally
pass.Free;
end;
end;
function TSSLStreamSec.DeInit: Boolean;
begin
Result := True;
if assigned(FSlave) then
begin
FSlave.Close;
FSlave.Free;
FSlave := nil;
end;
FSSLEnabled := false;
end;
function TSSLStreamSec.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLStreamSec.Connect: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(false) then
begin
FSlave.Open;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Accept: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(true) then
begin
FSlave.Open;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Shutdown: boolean;
begin
Result := BiShutdown;
end;
function TSSLStreamSec.BiShutdown: boolean;
begin
DeInit;
Result := True;
end;
function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := len;
FSlave.SendBuf(Buffer^, l, true);
Result := l;
SSLCheck;
end;
function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := Len;
Result := FSlave.ReceiveBuf(Buffer^, l);
SSLCheck;
end;
function TSSLStreamSec.WaitingData: Integer;
begin
Result := 0;
while FSlave.Connected do begin
Result := FSlave.ReceiveLength;
if Result > 0 then
Break;
Sleep(1);
end;
end;
function TSSLStreamSec.GetSSLVersion: string;
begin
Result := 'SSLv3 or TLSv1';
end;
function TSSLStreamSec.GetCert: PASN1Struct;
begin
if FIsServer then
Result := FSlave.GetClientCert
else
Result := FSlave.GetServerCert;
end;
function TSSLStreamSec.GetPeerSubject: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerName: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := XName.commonName.Str;
end;
end;
function TSSLStreamSec.GetPeerIssuer: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractIssuer(Cert^, XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerFingerprint: string;
var
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
Result := MD5(Cert.ContentAsOctetString);
end;
function TSSLStreamSec.GetCertInfo: string;
var
Cert: PASN1Struct;
l: Tstringlist;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
l := TStringList.Create;
try
Asn1.RenderAsText(cert^, l, true, true, true, 2);
Result := l.Text;
finally
l.free;
end;
end;
end;
function TSSLStreamSec.X500StrToStr(const Prefix: string;
const Value: TX500String): string;
begin
if Value.Str = '' then
Result := ''
else
Result := '/' + Prefix + '=' + Value.Str;
end;
function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
begin
Result := X500StrToStr('CN',Value.commonName) +
X500StrToStr('C',Value.countryName) +
X500StrToStr('L',Value.localityName) +
X500StrToStr('ST',Value.stateOrProvinceName) +
X500StrToStr('O',Value.organizationName) +
X500StrToStr('OU',Value.organizationalUnitName) +
X500StrToStr('T',Value.title) +
X500StrToStr('N',Value.name) +
X500StrToStr('G',Value.givenName) +
X500StrToStr('I',Value.initials) +
X500StrToStr('SN',Value.surname) +
X500StrToStr('GQ',Value.generationQualifier) +
X500StrToStr('DNQ',Value.dnQualifier) +
X500StrToStr('E',Value.emailAddress);
end;
{==============================================================================}
initialization
SSLImplementation := TSSLStreamSec;
finalization
end.

7
sslinux.pas
View File

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

153
synachar.pas
View File

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

4
synacode.pas
View File

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

13
synaicnv.pas
View File

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

185
synautil.pas
View File

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

29
tlntsend.pas
View File

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