pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 16

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@35 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 06:42:13 +00:00
parent 7daa8087a7
commit a68b85e498
4 changed files with 468 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
httpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.000 |
| Project : Delphree - Synapse | 001.002.000 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999. |
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -27,7 +27,7 @@ unit HTTPsend;
interface
uses
Blcksock, sysutils, classes, windows, SynaUtil;
Blcksock, sysutils, classes, windows, SynaUtil, SynaCode;
const
CRLF=#13+#10;
@ -39,13 +39,21 @@ type
public
timeout:integer;
HTTPHost:string;
HTTPPort:integer;
HTTPPort:string;
ProxyHost:string;
ProxyPort:string;
ProxyUser:string;
ProxyPass:string;
ResultCode:integer;
Constructor Create;
Destructor Destroy; override;
function Request(Query,Response:TStrings):Boolean;
function DoMethod(method,URL:string;Content,Response:TStrings):boolean;
end;
function get(Host,URI:string;Response:TStrings):Boolean;
function SimpleGet(URL:string;Response:TStrings):Boolean;
function Get(URL:string;Response:TStrings):Boolean;
function Post(URL:string;Value,Response:TStrings):Boolean;
implementation
@ -57,7 +65,11 @@ begin
sock.CreateSocket;
timeout:=300000;
HTTPhost:='localhost';
HTTPPort:=80;
HTTPPort:='80';
ProxyHost:='';
ProxyPort:='8080';
ProxyUser:='';
ProxyPass:='';
end;
{THTTPSend.Destroy}
@ -74,7 +86,7 @@ var
n:integer;
begin
Result:=False;
sock.Connect(HTTPHost,IntToStr(HTTPPort));
sock.Connect(HTTPHost,HTTPPort);
if sock.lasterror<>0 then Exit;
for n:=0 to Query.Count-1 do
Sock.SendString(Query[n]+CRLF);
@ -88,20 +100,84 @@ begin
Result:=True;
end;
{THTTPSend.DoMethod}
function THTTPSend.DoMethod(method,URL:string;Content,Response:TStrings):boolean;
var
Prot,User,Pass,Host,Port,Path,Para:string;
Query:TstringList;
size:integer;
s:string;
begin
result:=false;
Query:=TstringList.create;
try
parseURL(URL,Prot,User,Pass,Host,Port,Path,Para);
if content<>nil
then query.AddStrings(content);
size:=length(query.text);
query.insert(0,'');
query.insert(0,'User-Agent: Synapse/1.1');
query.insert(0,'Connection: close');
query.insert(0,'Accept-Encoding: identity');
if User<>''
then query.insert(0,'Authorization: Basic '+EncodeBase64(user+':'+pass));
if (proxyhost<>'') and (proxyUser<>'')
then query.insert(0,'Proxy-Authorization: Basic '+EncodeBase64(Proxyuser+':'+Proxypass));
if size>0
then query.insert(0,'Content-Length: '+inttostr(size));
query.insert(0,'Host: '+host+':'+port);
if para=''
then s:=''
else s:='?'+para;
s:=path+s;
if proxyHost<>''
then s:=prot+'://'+host+':'+port+s;
query.insert(0,uppercase(method)+' '+s+' HTTP/1.0');
if proxyhost=''
then
begin
HttpHost:=host;
HttpPort:=port;
end
else
begin
HttpHost:=Proxyhost;
HttpPort:=Proxyport;
end;
result:=request(query,response);
ResultCode:=0;
if response.count>0
then if pos('HTTP/',uppercase(response[0]))=1
then
begin
s:=separateright(response[0],' ');
s:=separateleft(s,' ');
ResultCode:=StrToIntDef(s,0);
end;
finally
Query.free;
end;
end;
{==============================================================================}
{get}
function get(Host,URI:string;Response:TStrings):Boolean;
{SimpleGet}
function SimpleGet(URL:string;Response:TStrings):Boolean;
var
HTTP:THTTPSend;
Query:TStringList;
Prot,User,Pass,Host,Port,Path,Para:string;
begin
parseURL(URL,Prot,User,Pass,Host,Port,Path,Para);
if para<>''
then path:=path+'?'+para;
Result:=False;
HTTP:=THTTPSend.Create;
Query:=TStringList.create;
try
HTTP.HTTPhost:=Host;
Query.Add('GET '+URI+' HTTP/0.9');
Query.Add('GET '+Path);
if not HTTP.Request(Query,Response) then Exit;
finally
Query.Free;
@ -110,4 +186,35 @@ begin
Result:=True;
end;
{get}
function Get(URL:string;Response:TStrings):Boolean;
var
HTTP:THTTPSend;
Prot,User,Pass,Host,Port,Path,Para:string;
begin
Result:=False;
HTTP:=THTTPSend.Create;
try
result:=HTTP.DoMethod('GET',URL,nil,Response);
finally
HTTP.Free;
end;
end;
{post}
function Post(URL:string;Value,Response:TStrings):Boolean;
var
HTTP:THTTPSend;
Prot,User,Pass,Host,Port,Path,Para:string;
begin
Result:=False;
HTTP:=THTTPSend.Create;
try
result:=HTTP.DoMethod('POST',URL,Value,Response);
finally
HTTP.Free;
end;
end;
end.

263
smtpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.003.000 |
| Project : Delphree - Synapse | 002.000.000 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999. |
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -27,7 +27,7 @@ unit SMTPsend;
interface
uses
Blcksock, sysutils, classes, windows, SynaUtil;
Blcksock, sysutils, classes, windows, SynaUtil, SynaCode;
const
CRLF=#13+#10;
@ -36,25 +36,43 @@ type
TSMTPSend = class
private
Sock:TTCPBlockSocket;
procedure EnhancedCode(value:string);
function ReadResult:integer;
public
timeout:integer;
SMTPHost:string;
ResultCode:integer;
ResultString:string;
FullResult:TStringList;
ESMTPcap:TStringList;
ESMTP:boolean;
Username:string;
Password:string;
AuthDone:boolean;
ESMTPSize:boolean;
MaxSize:integer;
EnhCode1:integer;
EnhCode2:integer;
EnhCode3:integer;
Constructor Create;
Destructor Destroy; override;
function AuthLogin:Boolean;
function AuthCram:Boolean;
function login:Boolean;
procedure logout;
function reset:Boolean;
function noop:Boolean;
function mailfrom(Value:string):Boolean;
function mailfrom(Value:string; size:integer):Boolean;
function mailto(Value:string):Boolean;
function maildata(Value:Tstrings):Boolean;
function etrn(Value:string):Boolean;
function verify(Value:string):Boolean;
function EnhCodeString:string;
end;
function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings):Boolean;
function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean;
function Sendto (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
function SendtoEx (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean;
implementation
@ -62,50 +80,160 @@ implementation
Constructor TSMTPSend.Create;
begin
inherited Create;
FullResult:=TStringList.create;
ESMTPcap:=TStringList.create;
sock:=TTCPBlockSocket.create;
sock.CreateSocket;
timeout:=300000;
SMTPhost:='localhost';
Username:='';
Password:='';
end;
{TSMTPSend.Destroy}
Destructor TSMTPSend.Destroy;
begin
Sock.free;
ESMTPcap.free;
FullResult.free;
inherited destroy;
end;
{TSMTPSend.EnhancedCode}
procedure TSMTPSend.EnhancedCode (value:string);
var
s,t:string;
e1,e2,e3:integer;
begin
EnhCode1:=0;
EnhCode2:=0;
EnhCode3:=0;
s:=copy(value,5,length(value)-4);
t:=separateleft(s,'.');
s:=separateright(s,'.');
if t='' then exit;
if length(t)>1 then exit;
e1:=strtointdef(t,0);
if e1=0 then exit;
t:=separateleft(s,'.');
s:=separateright(s,'.');
if t='' then exit;
if length(t)>3 then exit;
e2:=strtointdef(t,0);
t:=separateleft(s,' ');
if t='' then exit;
if length(t)>3 then exit;
e3:=strtointdef(t,0);
EnhCode1:=e1;
EnhCode2:=e2;
EnhCode3:=e3;
end;
{TSMTPSend.ReadResult}
function TSMTPSend.ReadResult:integer;
var
s:string;
begin
Result:=0;
FullResult.Clear;
repeat
s:=sock.recvstring(timeout);
ResultString:=s;
if Length(s)>=3 then Result:=Strtointdef(Copy(s,1,3),0);
while pos('-',s)=4 do
begin
s:=sock.recvstring(timeout);
FullResult.add(s);
if sock.LastError<>0 then
begin
Result:=0;
break;
end;
end;
until pos('-',s)<>4;
s:=FullResult[0];
if Length(s)>=3 then Result:=Strtointdef(Copy(s,1,3),0);
ResultCode:=Result;
EnhancedCode(s);
end;
{TSMTPSend.AuthLogin}
function TSMTPSend.AuthLogin:Boolean;
begin
Result:=false;
Sock.SendString('AUTH LOGIN'+CRLF);
if readresult<>334 then Exit;
Sock.SendString(Encodebase64(username)+CRLF);
if readresult<>334 then Exit;
Sock.SendString(Encodebase64(password)+CRLF);
if readresult<>235 then Exit;
Result:=True;
end;
{TSMTPSend.AuthCram}
function TSMTPSend.AuthCram:Boolean;
var
s,sm:string;
ipad,opad:string;
n,x:integer;
begin
Result:=false;
Sock.SendString('AUTH CRAM-MD5'+CRLF);
if readresult<>334 then Exit;
s:=copy(ResultString,5,length(ResultString)-4);
s:=DecodeBase64(s);
s:=HMAC_MD5(s,password);
s:=Username+' '+strtohex(s);
Sock.SendString(Encodebase64(s)+CRLF);
if readresult<>235 then Exit;
Result:=True;
end;
{TSMTPSend.login}
function TSMTPSend.login:Boolean;
var
n:integer;
auths:string;
begin
Result:=False;
ESMTP:=true;
AuthDone:=false;
ESMTPcap.clear;
ESMTPSize:=false;
MaxSize:=0;
sock.Connect(SMTPHost,'smtp');
if sock.lasterror<>0 then Exit;
if readresult<>220 then Exit;
Sock.SendString('EHLO '+sock.LocalName+CRLF);
if readresult<>250 then
begin
ESMTP:=false;
Sock.SendString('HELO '+sock.LocalName+CRLF);
if readresult<>250 then Exit;
end;
Result:=True;
if ESMTP then
begin
for n:=1 to FullResult.count-1 do
ESMTPcap.add(Copy(FullResult[n],5,length(Fullresult[n])-4));
if not ((Username='') and (Password='')) then
for n:=0 to ESMTPcap.count-1 do
begin
auths:=uppercase(ESMTPcap[n]);
if pos('AUTH ',auths)=1 then
begin
if pos('CRAM-MD5',auths)>0 then
begin
AuthDone:=AuthCram;
break;
end;
if pos('LOGIN',auths)>0 then
begin
AuthDone:=AuthLogin;
break;
end;
end;
end;
for n:=0 to ESMTPcap.count-1 do
if pos('SIZE',uppercase(ESMTPcap[n]))=1 then
begin
ESMTPsize:=true;
MaxSize:=StrToIntDef(copy(ESMTPcap[n],6,length(ESMTPcap[n])-5),0);
break;
end;
end;
end;
{TSMTPSend.logout}
@ -136,10 +264,15 @@ end;
{TSMTPSend.mailfrom}
function TSMTPSend.mailfrom(Value:string):Boolean;
function TSMTPSend.mailfrom(Value:string; size:integer):Boolean;
var
s:string;
begin
Result:=false;
Sock.SendString('MAIL FROM:<'+Value+'>'+CRLF);
s:='MAIL FROM:<'+Value+'>';
if ESMTPsize and (size>0)
then s:=s+' SIZE='+IntToStr(size);
Sock.SendString(s+CRLF);
if readresult<>250 then Exit;
Result:=True;
end;
@ -174,18 +307,105 @@ begin
Result:=True;
end;
{TSMTPSend.etrn}
function TSMTPSend.etrn(Value:string):Boolean;
begin
Result:=false;
Sock.SendString('ETRN '+Value+CRLF);
if (readresult<250) or (readresult>259) then Exit;
Result:=True;
end;
{TSMTPSend.verify}
function TSMTPSend.verify(Value:string):Boolean;
begin
Result:=false;
Sock.SendString('VRFY '+Value+CRLF);
if (readresult<250) or (readresult>259) then Exit;
Result:=True;
end;
{TSMTPSend.EnhCodeString}
function TSMTPSend.EnhCodeString:string;
var
s,t:string;
begin
s:=inttostr(EnhCode2)+'.'+inttostr(EnhCode3);
t:='';
if s='0.0' then t:='Other undefined Status';
if s='1.0' then t:='Other address status';
if s='1.1' then t:='Bad destination mailbox address';
if s='1.2' then t:='Bad destination system address';
if s='1.3' then t:='Bad destination mailbox address syntax';
if s='1.4' then t:='Destination mailbox address ambiguous';
if s='1.5' then t:='Destination mailbox address valid';
if s='1.6' then t:='Mailbox has moved';
if s='1.7' then t:='Bad sender''s mailbox address syntax';
if s='1.8' then t:='Bad sender''s system address';
if s='2.0' then t:='Other or undefined mailbox status';
if s='2.1' then t:='Mailbox disabled, not accepting messages';
if s='2.2' then t:='Mailbox full';
if s='2.3' then t:='Message length exceeds administrative limit';
if s='2.4' then t:='Mailing list expansion problem';
if s='3.0' then t:='Other or undefined mail system status';
if s='3.1' then t:='Mail system full';
if s='3.2' then t:='System not accepting network messages';
if s='3.3' then t:='System not capable of selected features';
if s='3.4' then t:='Message too big for system';
if s='3.5' then t:='System incorrectly configured';
if s='4.0' then t:='Other or undefined network or routing status';
if s='4.1' then t:='No answer from host';
if s='4.2' then t:='Bad connection';
if s='4.3' then t:='Routing server failure';
if s='4.4' then t:='Unable to route';
if s='4.5' then t:='Network congestion';
if s='4.6' then t:='Routing loop detected';
if s='4.7' then t:='Delivery time expired';
if s='5.0' then t:='Other or undefined protocol status';
if s='5.1' then t:='Invalid command';
if s='5.2' then t:='Syntax error';
if s='5.3' then t:='Too many recipients';
if s='5.4' then t:='Invalid command arguments';
if s='5.5' then t:='Wrong protocol version';
if s='6.0' then t:='Other or undefined media error';
if s='6.1' then t:='Media not supported';
if s='6.2' then t:='Conversion required and prohibited';
if s='6.3' then t:='Conversion required but not supported';
if s='6.4' then t:='Conversion with loss performed';
if s='6.5' then t:='Conversion failed';
if s='7.0' then t:='Other or undefined security status';
if s='7.1' then t:='Delivery not authorized, message refused';
if s='7.2' then t:='Mailing list expansion prohibited';
if s='7.3' then t:='Security conversion required but not possible';
if s='7.4' then t:='Security features not supported';
if s='7.5' then t:='Cryptographic failure';
if s='7.6' then t:='Cryptographic algorithm not supported';
if s='7.7' then t:='Message integrity failure';
s:='???-';
if EnhCode1=2 then s:='Success-';
if EnhCode1=4 then s:='Persistent Transient Failure-';
if EnhCode1=5 then s:='Permanent Failure-';
result:=s+t;
end;
{==============================================================================}
function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings):Boolean;
function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings;
Username,Password:string):Boolean;
var
SMTP:TSMTPSend;
size:integer;
begin
Result:=False;
SMTP:=TSMTPSend.Create;
try
SMTP.SMTPHost:=SMTPHost;
SMTP.Username:=Username;
SMTP.Password:=Password;
if not SMTP.login then Exit;
if not SMTP.mailfrom(mailfrom) then Exit;
size:=length(maildata.text);
if not SMTP.mailfrom(mailfrom,size) then Exit;
if not SMTP.mailto(mailto) then Exit;
if not SMTP.maildata(Maildata) then Exit;
SMTP.logout;
@ -195,7 +415,8 @@ begin
end;
end;
function Sendto (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
function SendtoEx (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings;
Username,Password:string):Boolean;
var
t:TStrings;
begin
@ -209,11 +430,15 @@ begin
t.Insert(0,'date: '+Rfc822DateTime(now));
t.Insert(0,'to: '+mailto);
t.Insert(0,'from: '+mailfrom);
result:=SendToRaw(mailfrom,mailto,SMTPHost,t);
result:=SendToRaw(mailfrom,mailto,SMTPHost,t,Username,Password);
finally
t.Free;
end;
end;
function Sendto (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
begin
result:=SendToEx(mailfrom,mailto,subject,SMTPHost,maildata,'','');
end;
end.

36
synacode.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.002.000 |
| Project : Delphree - Synapse | 001.003.000 |
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| Portions created by Lukas Gebauer are Copyright (c)2000, 2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -133,6 +133,7 @@ function Crc32(value:string):integer;
function UpdateCrc16(value:byte;crc16:word):word;
function Crc16(value:string):word;
function MD5(value:string):string;
function HMAC_MD5(text,key:string):string;
implementation
@ -557,6 +558,37 @@ begin
result:=MD5Final(MD5Context);
end;
{==============================================================================}
{HMAC_MD5}
function HMAC_MD5(text,key:string):string;
var
ipad,opad,s:string;
n:integer;
MD5Context : TMD5Ctx;
begin
if length(key)>64 then
key:=md5(key);
ipad:='';
for n:=1 to 64 do
ipad:=ipad+#$36;
opad:='';
for n:=1 to 64 do
opad:=opad+#$5c;
for n:=1 to length(key) do
begin
ipad[n]:=char(byte(ipad[n]) xor byte(key[n]));
opad[n]:=char(byte(opad[n]) xor byte(key[n]));
end;
MD5Init(MD5Context);
MD5Update(MD5Context,ipad);
MD5Update(MD5Context,text);
s:=MD5Final(MD5Context);
MD5Init(MD5Context);
MD5Update(MD5Context,opad);
MD5Update(MD5Context,s);
result:=MD5Final(MD5Context);
end;
{==============================================================================}
begin

69
synautil.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.006.000 |
| Project : Delphree - Synapse | 001.007.000 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999, 2000. |
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
@ -47,6 +47,7 @@ function GetEmailDesc(value:string):string;
function StrToHex(value:string):string;
function IntToBin(value:integer;digits:byte):string;
function BinToInt(value:string):integer;
procedure ParseURL(URL:string; var Prot,User,Pass,Host,Port,Path,Para:string);
implementation
@ -335,6 +336,70 @@ begin
end;
end;
{==============================================================================}
{ParseURL}
procedure ParseURL(URL:string; var Prot,User,Pass,Host,Port,Path,Para:string);
var
x:integer;
sURL:string;
s:string;
s1,s2:string;
begin
prot:='http';
user:='';
pass:='';
port:='80';
para:='';
x:=pos('://',URL);
if x>0 then
begin
prot:=separateleft(URL,'://');
sURL:=separateright(URL,'://');
end
else sURL:=URL;
x:=pos('@',sURL);
if x>0 then
begin
s:=separateleft(sURL,'@');
sURL:=separateright(sURL,'@');
x:=pos(':',s);
if x>0 then
begin
user:=separateleft(s,':');
pass:=separateright(s,':');
end
else user:=s;
end;
x:=pos('/',sURL);
if x>0 then
begin
s1:=separateleft(sURL,'/');
s2:=separateright(sURL,'/');
end
else
begin
s1:=sURL;
s2:='';
end;
x:=pos(':',s1);
if x>0 then
begin
host:=separateleft(s1,':');
port:=separateright(s1,':');
end
else host:=s1;
x:=pos('?',s2);
if x>0 then
begin
path:='/'+separateleft(s2,'?');
para:=separateright(s2,'?');
end
else path:='/'+s2;
if host=''
then host:='localhost';
end;
{==============================================================================}
end.