From 288e3ae3c3e10af82d82a85f138f0e403d3b6c64 Mon Sep 17 00:00:00 2001 From: geby Date: Thu, 24 Apr 2008 07:18:26 +0000 Subject: [PATCH] git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@61 7c85be65-684b-0410-a082-b2ed4fbef004 --- blcksock.pas | 201 ++++++++++++++-------- ftpsend.pas | 315 ++++++++++++++++++++++++++++++++++- httpsend.pas | 22 +-- imapsend.pas | 76 ++++++--- mimemess.pas | 43 +++-- mimepart.pas | 32 +++- pop3send.pas | 64 ++++++- smtpsend.pas | 42 ++++- synacode.pas | 15 +- SynaSSL.pas => synassl.pas.x | 23 ++- synautil.pas | 226 ++++++++++++++++--------- 11 files changed, 840 insertions(+), 219 deletions(-) rename SynaSSL.pas => synassl.pas.x (83%) diff --git a/blcksock.pas b/blcksock.pas index 13618ee..07e7816 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 005.002.000 | +| Project : Delphree - Synapse | 005.007.000 | |==============================================================================| | Content: Library base | |==============================================================================| @@ -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,2001. | +| Portions created by Lukas Gebauer are Copyright (c)1999-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -90,6 +90,7 @@ type FSocket: TSocket; FProtocol: Integer; procedure CreateSocket; virtual; + procedure AutoCreateSocket; procedure SetSin(var Sin: TSockAddrIn; IP, Port: string); function GetSinIP(Sin: TSockAddrIn): string; function GetSinPort(Sin: TSockAddrIn): Integer; @@ -201,6 +202,11 @@ type FSslBypass: Boolean; FSsl: PSSL; Fctx: PSSL_CTX; + FSSLPassword: string; + FSSLCiphers: string; + FSSLCertificateFile: string; + FSSLPrivateKeyFile: string; + FSSLCertCAFile: string; FHTTPTunnelIP: string; FHTTPTunnelPort: string; FHTTPTunnel: Boolean; @@ -209,6 +215,7 @@ type FHTTPTunnelUser: string; FHTTPTunnelPass: string; procedure SetSslEnabled(Value: Boolean); + function SetSslKeys: boolean; procedure SocksDoConnect(IP, Port: string); procedure HTTPTunnelDoConnect(IP, Port: string); public @@ -221,7 +228,7 @@ type procedure Connect(IP, Port: string); override; procedure SSLDoConnect; procedure SSLDoShutdown; - function SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean; + function SSLAcceptConnection: Boolean; function GetLocalSinIP: string; override; function GetRemoteSinIP: string; override; function GetLocalSinPort: Integer; override; @@ -237,6 +244,11 @@ type published property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled; property SSLBypass: Boolean read FSslBypass write FSslBypass; + property SSLPassword: string read FSSLPassword write FSSLPassword; + property SSLCiphers: string read FSSLCiphers write FSSLCiphers; + property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile; + property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile; + property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile; property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; property HTTPTunnel: Boolean read FHTTPTunnel; @@ -348,6 +360,8 @@ begin end; procedure TBlockSocket.SetSin(var Sin: TSockAddrIn; IP, Port: string); +type + pu_long = ^u_long; var ProtoEnt: PProtoEnt; ServEnt: PServEnt; @@ -373,10 +387,10 @@ begin begin HostEnt := synsock.GetHostByName(PChar(IP)); if HostEnt <> nil then - SIn.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^); + SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); end; end; - DoStatus(HR_ResolvingEnd, IP+':'+Port); + DoStatus(HR_ResolvingEnd, IP + ':' + Port); end; function TBlockSocket.GetSinIP(Sin: TSockAddrIn): string; @@ -406,10 +420,17 @@ begin DoStatus(HR_SocketCreate, ''); end; +procedure TBlockSocket.AutoCreateSocket; +begin + if FSocket = INVALID_SOCKET then + CreateSocket; +end; + procedure TBlockSocket.CloseSocket; begin synsock.Shutdown(FSocket, 2); synsock.CloseSocket(FSocket); + FSocket := INVALID_SOCKET; DoStatus(HR_SocketClose, ''); end; @@ -418,6 +439,7 @@ var Sin: TSockAddrIn; Len: Integer; begin + AutoCreateSocket; SetSin(Sin, IP, Port); SockCheck(synsock.Bind(FSocket, Sin, SizeOf(Sin))); Len := SizeOf(FLocalSin); @@ -431,6 +453,7 @@ procedure TBlockSocket.Connect(IP, Port: string); var Sin: TSockAddrIn; begin + AutoCreateSocket; SetSin(Sin, IP, Port); SockCheck(synsock.Connect(FSocket, Sin, SizeOf(Sin))); GetSins; @@ -452,13 +475,18 @@ end; procedure TBlockSocket.LimitBandwidth(Length: Integer); var x: Cardinal; + y: integer; begin if FMaxBandwidth > 0 then begin - x := FNextSend - GetTick; - if x > 0 then - Sleep(x); - FNextSend := GetTick + Trunc((FMaxBandwidth / 1000) * Length); + y:= GetTick; + if FNextSend > y then + begin + x:= FNextSend - y; + if x > 0 then + sleep(x); + end; + FNextSend:= y + Trunc((Length / FMaxBandwidth) * 1000); end; end; @@ -557,7 +585,6 @@ end; function TBlockSocket.RecvPacket(Timeout: Integer): string; var x: integer; - s: string; begin Result := ''; FLastError := 0; @@ -573,9 +600,9 @@ begin x := WaitingData; if x > 0 then begin - SetLength(s, x); - x := RecvBuffer(Pointer(s), x); - Result := Copy(s, 1, x); + SetLength(Result, x); + x := RecvBuffer(Pointer(Result), x); + SetLength(Result, x); end; end else @@ -587,59 +614,63 @@ end; function TBlockSocket.RecvByte(Timeout: Integer): Byte; -var - s: String; begin Result := 0; - if CanRead(Timeout) then - begin - SetLength(s, 1); - RecvBuffer(Pointer(s), 1); - if s <> '' then - Result := Ord(s[1]); - end - else + FLastError := 0; + if FBuffer = '' then + FBuffer := RecvPacket(Timeout); + if (FBuffer = '') and (FLastError = 0) then FLastError := WSAETIMEDOUT; + if FLastError = 0 then + begin + Result := Ord(FBuffer[1]); + System.Delete(FBuffer, 1, 1); + end; ExceptCheck; end; function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string; -const - MaxSize = 1024; var x: Integer; s: string; l: Integer; begin - s := ''; - l := Length(Terminator); + FLastError := 0; Result := ''; + l := system.Length(Terminator); if l = 0 then Exit; - FLastError := 0; - repeat - x := 0; - if FBuffer = '' then - begin - FBuffer := RecvPacket(Timeout); - if FLastError <> 0 then - Break; - end; - s := s + FBuffer; - FBuffer := ''; - x := Pos(Terminator, s); + // if FBuffer contains requested data, return it... + if FBuffer<>'' then + begin + x := pos(Terminator, FBuffer); if x > 0 then begin - FBuffer := Copy(s, x + l, Length(s) - x - l + 1); - s := Copy(s, 1, x - 1); + Result := copy(FBuffer, 1, x - 1); + System.Delete(FBuffer, 1, x + l - 1); + exit; end; - if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then + end; + // now FBuffer is empty or not contains all data... + s := ''; + x := 0; + repeat + s := s + RecvPacket(Timeout); + if FLastError <> 0 then + Break; + x := Pos(Terminator, s); + if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then begin FLastError := WSAENOBUFS; Break; end; until x > 0; - Result := s; + if x > 0 then + begin + Result := Copy(s, 1, x - 1); + System.Delete(s, 1, x + l - 1); + end; + FBuffer := s; ExceptCheck; end; @@ -1341,6 +1372,7 @@ end; procedure TUDPBlockSocket.Connect(IP, Port: string); begin + AutoCreateSocket; SetRemoteSin(IP, Port); FBuffer := ''; DoStatus(HR_Connect, IP + ':' + Port); @@ -1459,11 +1491,29 @@ end; {======================================================================} +function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; +var + Password: String; +begin + Password := ''; + if TTCPBlockSocket(userdata) is TTCPBlockSocket then + Password := TTCPBlockSocket(userdata).SSLPassword; + FillChar(buf, Size, 0); + if Length(Password) > (Size - 1) then + SetLength(Password, Size - 1); + StrPCopy(buf, Password); + Result := Length(Password); +end; + constructor TTCPBlockSocket.Create; begin inherited Create; FSslEnabled := False; FSslBypass := False; + FSSLCiphers := 'DEFAULT'; + FSSLCertificateFile := ''; + FSSLPrivateKeyFile := ''; + FSSLPassword := ''; FSsl := nil; Fctx := nil; FHTTPTunnelIP := ''; @@ -1554,6 +1604,7 @@ end; procedure TTCPBlockSocket.Connect(IP, Port: string); begin + AutoCreateSocket; if FSocksIP <> '' then SocksDoConnect(IP, Port) else @@ -1570,41 +1621,47 @@ var b: Boolean; begin inherited Connect(FSocksIP, FSocksPort); - b := SocksOpen; - if b then - b := SocksRequest(1, IP, Port); - if b then - b := SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSASYSNOTREADY; - FSocksLocalIP := FSocksResponseIP; - FSocksLocalPort := FSocksResponsePort; - FSocksRemoteIP := IP; - FSocksRemotePort := Port; + if FLastError = 0 then + begin + b := SocksOpen; + if b then + b := SocksRequest(1, IP, Port); + if b then + b := SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSASYSNOTREADY; + FSocksLocalIP := FSocksResponseIP; + FSocksLocalPort := FSocksResponsePort; + FSocksRemoteIP := IP; + FSocksRemotePort := Port; + end; ExceptCheck; DoStatus(HR_Connect, IP + ':' + Port); end; procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); +//bugfixed by Mike Green (mgreen@emixode.com) var s: string; begin try FBypassFlag := True; inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); + if FLastError <> 0 then + Exit; FHTTPTunnel := False; - SendString('CONNECT ' + IP + ':' + Port + 'HTTP/1.0' + #$0d + #$0a); + SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + #$0d + #$0a); if FHTTPTunnelUser <> '' then Sendstring('Proxy-Authorization: Basic ' + EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a); SendString(#$0d + #$0a); repeat - s := RecvString(30000); + s := RecvTerminated(30000, #$0a); if FLastError <> 0 then Break; if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then FHTTPTunnel := s[10] = '2'; - until s = ''; + until (s = '') or (s = #$0d); if (FLasterror = 0) and not FHTTPTunnel then FLastError := WSASYSNOTREADY; FHTTPTunnelRemoteIP := IP; @@ -1675,6 +1732,18 @@ begin Result := inherited GetRemoteSinPort; end; +function TTCPBlockSocket.SetSslKeys: boolean; +begin + Result := False; + if FSSLCertificateFile <> '' then + SslCtxUseCertificateChainFile(FCtx, PChar(FSSLCertificateFile)); + if FSSLPrivateKeyFile <> '' then + SslCtxUsePrivateKeyFile(FCtx, PChar(FSSLPrivateKeyFile), 1); + if FSSLCertCAFile <> '' then + SslCtxLoadVerifyLocations(FCtx, PChar(FSSLCertCAFile), nil); + Result := True; +end; + procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean); begin if Value <> FSslEnabled then @@ -1682,10 +1751,14 @@ begin begin if InitSSLInterface then begin - SslLoadErrorStrings; SslLibraryInit; + SslLoadErrorStrings; Fctx := nil; Fctx := SslCtxNew(SslMethodV23); + SslCtxSetCipherList(Fctx, PChar(FSSLCiphers)); + SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); + SslCtxSetDefaultPasswdCbUserdata(FCtx, self); + SetSSLKeys; Fssl := nil; Fssl := SslNew(Fctx); FSslEnabled := True; @@ -1747,18 +1820,14 @@ begin Result := inherited SendBuffer(Buffer, Length); end; -function TTCPBlockSocket.SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean; +function TTCPBlockSocket.SSLAcceptConnection: Boolean; begin Result := False; FLastError := 0; - if SslCtxUseCertificateFile(FCtx, PChar(Certificate), 1) < 0 then + if not FSSLEnabled then + SSLEnabled := True; + if sslsetfd(FSsl, FSocket) < 0 then FLastError := WSASYSNOTREADY; - if (FLastError = 0) then - if SslCtxUsePrivateKeyFile(FCtx, PChar(PrivateKey), 1) < 0 then - FLastError := WSASYSNOTREADY; - if (FLastError = 0) then - if sslsetfd(FSsl, FSocket) < 0 then - FLastError := WSASYSNOTREADY; if (FLastError = 0) then if sslAccept(FSsl) < 0 then FLastError := WSASYSNOTREADY; diff --git a/ftpsend.pas b/ftpsend.pas index 54f7176..fc866e4 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.002.002 | +| Project : Delphree - Synapse | 002.000.000 | |==============================================================================| | Content: FTP 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,2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -47,6 +47,27 @@ type TFTPStatus = procedure(Sender: TObject; Response: Boolean; const Value: string) of object; + TFTPListRec = class(TObject) + public + FileName: string; + Directory: Boolean; + Readable: Boolean; + FileSize: Longint; + FileTime: TDateTime; + end; + + TFTPList = class(TObject) + private + FList: TList; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + function ParseLine(Value: string): Boolean; + published + property List: TList read FList; + end; + TFTPSend = class(TObject) private FOnStatus: TFTPStatus; @@ -74,6 +95,7 @@ type FCanResume: Boolean; FPassiveMode: Boolean; FForceDefaultPort: Boolean; + FFtpList: TFTPList; function Auth(Mode: integer): Boolean; function Connect: Boolean; function InternalStor(const Command: string; RestoreAt: integer): Boolean; @@ -132,6 +154,7 @@ type property PassiveMode: Boolean read FPassiveMode Write FPassiveMode; property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort; property OnStatus: TFTPStatus read FOnStatus write FOnStatus; + property FtpList: TFTPList read FFtpList; end; function FtpGetFile(const IP, Port, FileName, LocalFile, @@ -154,6 +177,7 @@ begin FDataStream := TMemoryStream.Create; FSock := TTCPBlockSocket.Create; FDSock := TTCPBlockSocket.Create; + FFtpList := TFTPList.Create; FTimeout := 300000; FFTPHost := cLocalhost; FFTPPort := cFtpProtocol; @@ -174,6 +198,7 @@ destructor TFTPSend.Destroy; begin FDSock.Free; FSock.Free; + FFTPList.Free; FDataStream.Free; FFullResult.Free; inherited Destroy; @@ -344,11 +369,12 @@ begin FTPCommand('TYPE I'); FTPCommand('STRU F'); FTPCommand('MODE S'); - if FTPCommand('REST 1') = 350 then - begin - FTPCommand('REST 0'); - FCanResume := True; - end; + if FTPCommand('REST 0') = 350 then + if FTPCommand('REST 1') = 350 then + begin + FTPCommand('REST 0'); + FCanResume := True; + end; Result := True; end; @@ -508,9 +534,11 @@ end; function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; var x: integer; + l: TStringList; begin Result := False; FDataStream.Clear; + FFTPList.Clear; if Directory <> '' then Directory := ' ' + Directory; if not DataSocket then @@ -523,6 +551,18 @@ begin if (x div 100) <> 1 then Exit; Result := DataRead(FDataStream); + if not NameList then + begin + l := TStringList.Create; + try + FDataStream.Seek(0, soFromBeginning); + l.LoadFromStream(FDataStream); + for x := 0 to l.Count - 1 do + FFTPList.ParseLine(l[x]); + finally + l.Free; + end; + end; FDataStream.Seek(0, soFromBeginning); end; @@ -703,6 +743,267 @@ end; {==============================================================================} +constructor TFTPList.Create; +begin + inherited Create; + FList := TList.Create; +end; + +destructor TFTPList.Destroy; +begin + Clear; + FList.Free; + inherited Destroy; +end; + +procedure TFTPList.Clear; +var + n:integer; +begin + for n := 0 to FList.Count - 1 do + if Assigned(FList[n]) then + TFTPListRec(FList[n]).Free; + FList.Clear; +end; + +// based on idea by D. J. Bernstein, djb@pobox.com +function TFTPList.ParseLine(Value: string): Boolean; +var + flr: TFTPListRec; + s: string; + state: integer; + year: Word; + month: Word; + mday: Word; + t: TDateTime; + x: integer; +begin + Result := False; + if Length(Value) < 2 then + Exit; + year := 0; + month := 0; + mday := 0; + t := 0; + flr := TFTPListRec.Create; + try + flr.FileName := ''; + flr.Directory := False; + flr.Readable := False; + flr.FileSize := 0; + flr.FileTime := 0; + Value := Trim(Value); + {EPLF + See http://pobox.com/~djb/proto/eplf.txt + "+i8388621.29609,m824255902,/," + #9 + "tdev" + "+i8388621.44468,m839956783,r,s10376," + #9 + "RFCEPLF" } + if Value[1] = '+' then + begin + s := Fetch(Value, ','); + while s <> '' do + begin + if s[1] = #9 then + begin + flr.FileName := Copy(s, 2, Length(s) - 1); + Result := True; + end; + case s[1] of + '/': + flr.Directory := true; + 'r': + flr.Readable := true; + 's': + flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0); + 'm': + flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400) + + 25569; + end; + s := Fetch(Value, ','); + end; + Exit; + end; + + {UNIX-style listing, without inum and without blocks + Permissions Owner Group Size Date/Time Name + + "-rw-r--r-- 1 root other 531 Jan 29 03:26 README" + "dr-xr-xr-x 2 root other 512 Apr 8 1994 etc" + "dr-xr-xr-x 2 root 512 Apr 8 1994 etc" + "lrwxrwxrwx 1 root other 7 Jan 25 00:17 bin -> usr/bin" + + Also produced by Microsoft's FTP servers for Windows: + "---------- 1 owner group 1803128 Jul 10 10:18 ls-lR.Z" + + Also WFTPD for MSDOS: + "-rwxrwxrwx 1 noone nogroup 322 Aug 19 1996 message.ftp" + + Also NetWare: + "d [R----F--] supervisor 512 Jan 16 18:53 login" + "- [R----F--] rhesus 214059 Oct 20 15:27 cx.exe" + + Also NetPresenz for the Mac: + "-------r-- 326 1391972 1392298 Nov 22 1995 MegaPhone.sit" + "drwxrwxr-x folder 2 May 10 1996 network" } + + if (Value[1] = 'b') or + (Value[1] = 'c') or + (Value[1] = 'd') or + (Value[1] = 'l') or + (Value[1] = 'p') or + (Value[1] = 's') or + (Value[1] = '-') then + begin + if Value[1] = 'd' then + flr.Directory := True; + if Value[1] = '-' then + flr.Readable := True; + if Value[1] = 'l' then + begin + flr.Directory := True; + flr.Readable := True; + end; + state := 1; + s := Fetch(Value, ' '); + while s <> '' do + begin + case state of + 1: + begin + state := 2; + if (s[1] = 'f') and (Pos(' ', s) = 6) then + state := 3; + end; + 2: + state := 3; + 3: + begin + flr.FileSize := StrToIntDef(s, 0); + state := 4; + end; + 4: + begin + month := GetMonthNumber(s); + if month > 0 then + state := 5 + else + flr.FileSize := StrToIntDef(s, 0); + end; + 5: + begin + mday := StrToIntDef(s, 0); + state := 6; + end; + 6: + begin + if (Pos(':', s) > 0) then + t := GetTimeFromStr(s) + else + if Length(s) = 4 then + year := StrToIntDef(s, 0) + else Exit; + if (year = 0) or (month = 0) or (mday = 0) then + Exit; + flr.FileTime := t + Encodedate(year, month, mday); + state := 7; + end; + 7: + begin + flr.FileName := s; + Result := True; + end; + end; + s := Fetch(Value, ' '); + end; + Exit; + end; + {Microsoft NT 4.0 FTP Service + 10-20-98 08:57AM 619098 rizrem.zip + 11-12-98 11:54AM test } + if (Value[1] = '1') or (Value[1] = '0') then + begin + if Length(Value) < 8 then + Exit; + if (Ord(Value[2]) < 48) or (Ord(Value[2]) > 57) then + Exit; + if Value[3] <> '-' then + Exit; + s := Fetch(Value, ' '); + t := GetDateMDYFromStr(s); + if t = 0 then + Exit; + if Value = '' then + Exit; + s := Fetch(Value, ' '); + flr.FileTime := t + GetTimeFromStr(s); + if Value = '' then + Exit; + s := Fetch(Value, ' '); + if s[1] = '<' then + flr.Directory := True + else + begin + flr.Readable := true; + flr.Filesize := StrToIntDef(s, 0); + end; + if Value = '' then + Exit; + s := Fetch(Value, ' '); + flr.FileName := s; + Result := True; + Exit; + end; + {MultiNet + "00README.TXT;1 2 30-DEC-1996 17:44 [SYSTEM] (RWED,RWED,RE,RE)" + "CORE.DIR;1 1 8-SEP-1996 16:09 [SYSTEM] (RWE,RWE,RE,RE)" + + and non-MutliNet VMS: + "CII-MANUAL.TEX;1 213/216 29-JAN-1996 03:33:12 [ANONYMOU,ANONYMOUS] (RWED,RWED,,)" } + x := Pos(';', Value); + if x > 0 then + begin + s := Fetch(Value, ';'); + if Uppercase(Copy(s,Length(s) - 4, 4)) = '.DIR' then + begin + flr.FileName := Copy(s, 1, Length(s) - 4); + flr.Directory := True; + end + else + begin + flr.FileName := s; + flr.Readable := True; + end; + s := Fetch(Value, ' '); + s := Fetch(Value, ' '); + if Value = '' then + Exit; + s := Fetch(Value, '-'); + mday := StrToIntDef(s, 0); + s := Fetch(Value, '-'); + month := GetMonthNumber(s); + s := Fetch(Value, ' '); + year := StrToIntDef(s, 0); + s := Fetch(Value, ' '); + if Value = '' then + Exit; + if (year = 0) or (month = 0) or (mday = 0) then + Exit; + flr.FileTime := GetTimeFromStr(s) + EncodeDate(year, month, mday); + Result := True; + Exit; + end; + finally + if Result then + if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then + Result := False; + if Result then + FList.Add(flr) + else + flr.Free; + end; +end; + +{==============================================================================} + function FtpGetFile(const IP, Port, FileName, LocalFile, User, Pass: string): Boolean; begin diff --git a/httpsend.pas b/httpsend.pas index c80e8f2..75c45fb 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.000.000 | +| Project : Delphree - Synapse | 003.000.003 | |==============================================================================| | 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,2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -115,7 +115,7 @@ begin FProxyPass := ''; FAliveHost := ''; FAlivePort := ''; - FProtocol := '1.1'; + FProtocol := '1.0'; FKeepAlive := True; Clear; end; @@ -254,10 +254,10 @@ begin end; { send Headers } - FSock.SendString(Headers[0] + CRLF); - if FProtocol <> '0.9' then - for n := 1 to FHeaders.Count - 1 do - FSock.SendString(FHeaders[n] + CRLF); + if FProtocol = '0.9' then + FSock.SendString(FHeaders[0] + CRLF) + else + FSock.SendString(FHeaders.Text); if FSock.LastError <> 0 then Exit; @@ -470,7 +470,7 @@ begin HTTP := THTTPSend.Create; try HTTP.Document.Write(Pointer(URLData)^, Length(URLData)); - HTTP.MimeType := 'application/x-url-encoded'; + HTTP.MimeType := 'application/x-www-form-urlencoded'; Result := HTTP.HTTPMethod('POST', URL); Data.CopyFrom(HTTP.Document, 0); finally @@ -486,16 +486,16 @@ var HTTP: THTTPSend; Bound, s: string; begin - Bound := '--' + IntToHex(Random(MaxInt), 8) + '_Synapse_boundary'; + Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary'; HTTP := THTTPSend.Create; try - s := Bound + CRLF; + s := '--' + Bound + CRLF; s := s + 'content-disposition: form-data; name="' + FieldName + '";'; s := s + ' filename="' + FileName +'"' + CRLF; s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF; HTTP.Document.Write(Pointer(s)^, Length(s)); HTTP.Document.CopyFrom(Data, 0); - s := CRLF + Bound + '--' + CRLF; + s := CRLF + '--' + Bound + '--' + CRLF; HTTP.Document.Write(Pointer(s)^, Length(s)); HTTP.MimeType := 'multipart/form-data, boundary=' + Bound; Result := HTTP.HTTPMethod('POST', URL); diff --git a/imapsend.pas b/imapsend.pas index adb881b..0cc5ce3 100644 --- a/imapsend.pas +++ b/imapsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.001 | +| Project : Delphree - Synapse | 002.000.000 | |==============================================================================| | Content: IMAP4rev1 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)2001. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -26,6 +26,7 @@ {$WEAKPACKAGEUNIT ON} //RFC-2060 +//RFC-2595 unit IMAPsend; @@ -57,7 +58,8 @@ type FSelectedRecent: integer; FSelectedUIDvalidity: integer; FUID: Boolean; - + FAutoTLS: Boolean; + FFullSSL: Boolean; function ReadResult: string; function AuthLogin: Boolean; function Connect: Boolean; @@ -70,6 +72,7 @@ type destructor Destroy; override; function IMAPcommand(Value: string): string; function IMAPuploadCommand(Value: string; const Data:TStrings): string; + function Capability: Boolean; function Login: Boolean; procedure Logout; function NoOp: Boolean; @@ -95,7 +98,7 @@ type function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; function SetFlagsMess(MessID: integer; Flags: string): Boolean; function GetFlagsMess(MessID: integer; var Flags: string): Boolean; - + function StartTLS: Boolean; function FindCap(const Value: string): string; published property Timeout: Integer read FTimeout Write FTimeout; @@ -113,6 +116,8 @@ type property SelectedCount: integer read FSelectedCount; property SelectedRecent: integer read FSelectedRecent; property SelectedUIDvalidity: integer read FSelectedUIDvalidity; + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + property FullSSL: Boolean read FFullSSL Write FFullSSL; end; implementation @@ -140,6 +145,8 @@ begin FSelectedRecent := 0; FSelectedUIDvalidity := 0; FUID := False; + FAutoTLS := False; + FFullSSL := False; end; destructor TIMAPSend.Destroy; @@ -307,31 +314,18 @@ function TIMAPSend.Connect: Boolean; begin FSock.CloseSocket; FSock.CreateSocket; + if FFullSSL then + FSock.SSLEnabled := True; FSock.Connect(FIMAPHost, FIMAPPort); Result := FSock.LastError = 0; end; -function TIMAPSend.Login: Boolean; +function TIMAPSend.Capability: Boolean; var n: Integer; s, t: string; begin - FSelectedFolder := ''; - FSelectedCount := 0; - FSelectedRecent := 0; - FSelectedUIDvalidity := 0; Result := False; - FAuthDone := False; - if not Connect then - Exit; - s := FSock.RecvString(FTimeout); - if Pos('* PREAUTH', s) = 1 then - FAuthDone := True - else - if Pos('* OK', s) = 1 then - FAuthDone := False - else - Exit; FIMAPcap.Clear; s := IMAPcommand('CAPABILITY'); if s = 'OK' then @@ -349,8 +343,37 @@ begin FIMAPcap.Add(t); end; end; + Result := True; + end; +end; + +function TIMAPSend.Login: Boolean; +var + s: string; +begin + FSelectedFolder := ''; + FSelectedCount := 0; + FSelectedRecent := 0; + FSelectedUIDvalidity := 0; + Result := False; + FAuthDone := False; + if not Connect then + Exit; + s := FSock.RecvString(FTimeout); + if Pos('* PREAUTH', s) = 1 then + FAuthDone := True + else + if Pos('* OK', s) = 1 then + FAuthDone := False + else + Exit; + if Capability then + begin if Findcap('IMAP4rev1') = '' then Exit; + if FAutoTLS and (Findcap('STARTTLS') <> '') then + if StartTLS then + Capability; end; Result := AuthLogin; end; @@ -570,6 +593,19 @@ begin end; end; +function TIMAPSend.StartTLS: Boolean; +begin + Result := False; + if FindCap('STARTTLS') <> '' then + begin + if IMAPcommand('STARTTLS') = 'OK' then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; + end; +end; + {==============================================================================} end. diff --git a/mimemess.pas b/mimemess.pas index dfab7b4..7eadf62 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.007.002 | +| Project : Delphree - Synapse | 001.007.004 | |==============================================================================| | Content: MIME message object | |==============================================================================| @@ -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,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -221,6 +221,18 @@ begin FDate := DecodeRfcDateTime(SeparateRight(s, ':')); continue; end; + if Pos('MIME-VERSION:', UpperCase(s)) = 1 then + continue; + if Pos('CONTENT-TYPE:', UpperCase(s)) = 1 then + continue; + if Pos('CONTENT-DESCRIPTION:', UpperCase(s)) = 1 then + continue; + if Pos('CONTENT-DISPOSITION:', UpperCase(s)) = 1 then + continue; + if Pos('CONTENT-ID:', UpperCase(s)) = 1 then + continue; + if Pos('CONTENT-TRANSFER-ENCODING:', UpperCase(s)) = 1 then + continue; FCustomHeaders.Add(s); end; end; @@ -231,7 +243,7 @@ var begin Result := ''; for n := 0 to FCustomHeaders.Count - 1 do - if Pos(Value, FCustomHeaders[n]) = 1 then + if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then begin Result := SeparateRight(FCustomHeaders[n], ':'); break; @@ -244,7 +256,7 @@ var begin HeaderList.Clear; for n := 0 to FCustomHeaders.Count - 1 do - if Pos(Value, FCustomHeaders[n]) = 1 then + if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then begin HeaderList.Add(SeparateRight(FCustomHeaders[n], ':')); end; @@ -370,30 +382,35 @@ procedure TMimeMess.EncodeMessage; var bound: string; n: Integer; + m:TMimepart; begin FLines.Clear; if FPartList.Count = 1 then + begin + TMimePart(FPartList[0]).EncodePart; FLines.Assign(TMimePart(FPartList[0]).Lines) + end else begin bound := GenerateBoundary; for n := 0 to FPartList.Count - 1 do begin FLines.Add('--' + bound); + TMimePart(FPartList[n]).EncodePart; FLines.AddStrings(TMimePart(FPartList[n]).Lines); end; FLines.Add('--' + bound + '--'); - with TMimePart.Create do + m := TMimePart.Create; try - Self.FLines.SaveToStream(DecodedLines); - Primary := 'Multipart'; - Secondary := FMultipartType; - Description := 'Multipart message'; - Boundary := bound; - EncodePart; - Self.FLines.Assign(Lines); + FLines.SaveToStream(m.DecodedLines); + m.Primary := 'Multipart'; + m.Secondary := FMultipartType; + m.Description := 'Multipart message'; + m.Boundary := bound; + m.EncodePart; + FLines.Assign(m.Lines); finally - Free; + m.Free; end; end; end; diff --git a/mimepart.pas b/mimepart.pas index aa93104..0b62362 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.008.001 | +| Project : Delphree - Synapse | 001.008.004 | |==============================================================================| | Content: MIME 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)2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -415,6 +415,7 @@ var l: TStringList; s, t: string; n, x: Integer; + d1, d2: integer; const MaxLine = 75; begin @@ -453,10 +454,27 @@ begin begin s := EncodeQuotedPrintable(s); repeat - t := Copy(s, 1, MaxLine); - s := Copy(s, MaxLine + 1, Length(s) - MaxLine); - if s <> '' then - t := t + '='; + if Length(s) < MaxLine then + begin + t := s; + s := ''; + end + else + begin + d1 := RPosEx('=', s, MaxLine); + d2 := RPosEx(' ', s, MaxLine); + if (d1 = 0) and (d2 = 0) then + x := MaxLine + else + if d1 > d2 then + x := d1 - 1 + else + x := d2 - 1; + t := Copy(s, 1, x); + s := Copy(s, x + 1, Length(s) - x); + if s <> '' then + t := t + '='; + end; FLines.Add(t); until s = ''; end @@ -596,7 +614,7 @@ var begin Randomize; x := Random(MaxInt); - Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary--'; + Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary'; end; end. diff --git a/pop3send.pas b/pop3send.pas index eb254f0..5151bc8 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.002.000 | +| Project : Delphree - Synapse | 002.000.000 | |==============================================================================| | Content: POP3 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)2001. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -25,6 +25,12 @@ {$WEAKPACKAGEUNIT ON} +//RFC-1734 +//RFC-1939 +//RFC-2195 +//RFC-2449 +//RFC-2595 + unit POP3send; interface @@ -54,6 +60,9 @@ type FStatSize: Integer; FTimeStamp: string; FAuthType: TPOP3AuthType; + FPOP3cap: TStringList; + FAutoTLS: Boolean; + FFullSSL: Boolean; function ReadResult(Full: Boolean): Integer; function Connect: Boolean; function AuthLogin: Boolean; @@ -61,6 +70,7 @@ type public constructor Create; destructor Destroy; override; + function Capability: Boolean; function Login: Boolean; procedure Logout; function Reset: Boolean; @@ -71,6 +81,8 @@ type function Dele(Value: Integer): Boolean; function Top(Value, Maxlines: Integer): Boolean; function Uidl(Value: Integer): Boolean; + function StartTLS: Boolean; + function FindCap(const Value: string): string; published property Timeout: Integer read FTimeout Write FTimeout; property POP3Host: string read FPOP3Host Write FPOP3Host; @@ -85,6 +97,8 @@ type property TimeStamp: string read FTimeStamp; property AuthType: TPOP3AuthType read FAuthType Write FAuthType; property Sock: TTCPBlockSocket read FSock; + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + property FullSSL: Boolean read FFullSSL Write FFullSSL; end; implementation @@ -96,6 +110,7 @@ constructor TPOP3Send.Create; begin inherited Create; FFullResult := TStringList.Create; + FPOP3cap := TStringList.Create; FSock := TTCPBlockSocket.Create; FSock.CreateSocket; FTimeout := 300000; @@ -106,11 +121,14 @@ begin FStatCount := 0; FStatSize := 0; FAuthType := POP3AuthAll; + FAutoTLS := False; + FFullSSL := False; end; destructor TPOP3Send.Destroy; begin FSock.Free; + FPOP3cap.Free; FullResult.Free; inherited Destroy; end; @@ -162,10 +180,22 @@ begin FSock.CloseSocket; FSock.LineBuffer := ''; FSock.CreateSocket; + if FFullSSL then + FSock.SSLEnabled := True; FSock.Connect(POP3Host, POP3Port); Result := FSock.LastError = 0; end; +function TPOP3Send.Capability: Boolean; +begin + FPOP3cap.Clear; + Result := False; + FSock.SendString('CAPA' + CRLF); + Result := ReadResult(True) = 1; + if Result then + FPOP3cap.AddStrings(FFullResult); +end; + function TPOP3Send.Login: Boolean; var s, s1: string; @@ -184,6 +214,10 @@ begin FTimeStamp := '<' + s1 + '>'; end; Result := False; + if Capability then + if FAutoTLS and (Findcap('STLS') <> '') then + if StartTLS then + Capability; if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then begin Result := AuthApop; @@ -268,4 +302,30 @@ begin Result := ReadResult(Value = 0) = 1; end; +function TPOP3Send.StartTLS: Boolean; +begin + Result := False; + FSock.SendString('STLS' + CRLF); + if ReadResult(False) = 1 then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; +end; + +function TPOP3Send.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FPOP3cap.Count - 1 do + if Pos(s, UpperCase(FPOP3cap[n])) = 1 then + begin + Result := FPOP3cap[n]; + Break; + end; +end; + end. diff --git a/smtpsend.pas b/smtpsend.pas index 62671a5..9b741cb 100644 --- a/smtpsend.pas +++ b/smtpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.002.000 | +| Project : Delphree - Synapse | 003.001.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,2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -57,6 +57,8 @@ type FEnhCode2: Integer; FEnhCode3: Integer; FSystemName: string; + FAutoTLS: Boolean; + FFullSSL: Boolean; procedure EnhancedCode(const Value: string); function ReadResult: Integer; function AuthLogin: Boolean; @@ -76,6 +78,7 @@ type function MailData(const Value: Tstrings): Boolean; function Etrn(const Value: string): Boolean; function Verify(const Value: string): Boolean; + function StartTLS: Boolean; function EnhCodeString: string; function FindCap(const Value: string): string; published @@ -97,6 +100,8 @@ type property EnhCode3: Integer read FEnhCode3; property SystemName: string read FSystemName Write FSystemName; property Sock: TTCPBlockSocket read FSock; + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + property FullSSL: Boolean read FFullSSL Write FFullSSL; end; function SendToRaw(const MailFrom, MailTo, SMTPHost: string; @@ -124,6 +129,8 @@ begin FUsername := ''; FPassword := ''; FSystemName := FSock.LocalName; + FAutoTLS := False; + FFullSSL := False; end; destructor TSMTPSend.Destroy; @@ -223,6 +230,8 @@ function TSMTPSend.Connect: Boolean; begin FSock.CloseSocket; FSock.CreateSocket; + if FFullSSL then + FSock.SSLEnabled := True; FSock.Connect(FSMTPHost, FSMTPPort); Result := FSock.LastError = 0; end; @@ -272,6 +281,14 @@ begin begin for n := 1 to FFullResult.Count - 1 do FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); + if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then + if StartTLS then + begin + Ehlo; + FESMTPcap.Clear; + for n := 1 to FFullResult.Count - 1 do + FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); + end; if not ((FUsername = '') and (FPassword = '')) then begin s := FindCap('AUTH '); @@ -372,6 +389,20 @@ begin Result := (x >= 250) and (x <= 259); end; +function TSMTPSend.StartTLS: Boolean; +begin + Result := False; + if FindCap('STARTTLS') <> '' then + begin + FSock.SendString('STARTTLS' + CRLF); + if (ReadResult = 220) and (FSock.LastError = 0) then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; + end; +end; + function TSMTPSend.EnhCodeString: string; var s, t: string; @@ -460,6 +491,13 @@ begin Result := False; SMTP := TSMTPSend.Create; try +// if you need SOCKS5 support, uncomment next lines: + // SMTP.Sock.SocksIP := '127.0.0.1'; + // SMTP.Sock.SocksPort := '1080'; +// if you need support for upgrade session to TSL/SSL, uncomment next lines: + // SMTP.AutoTLS := True; +// if you need support for TSL/SSL tunnel, uncomment next lines: + // SMTP.FullSSL := True; SMTP.SMTPHost := SeparateLeft(SMTPHost, ':'); s := SeparateRight(SMTPHost, ':'); if (s <> '') and (s <> SMTPHost) then diff --git a/synacode.pas b/synacode.pas index 015e836..4c4d844 100644 --- a/synacode.pas +++ b/synacode.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.005.003 | +| Project : Delphree - Synapse | 001.005.005 | |==============================================================================| | 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, 2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2002. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -239,11 +239,10 @@ begin begin s := Copy(Value, x, 2); Inc(x, 2); - if pos(#13, s) + pos(#10, s) = 0 then - Result[l] := Char(StrToIntDef('$' + s, 32)) - else - Result[l] := ' '; - end; + Result[l] := Char(StrToIntDef('$' + s, 32)) + end + else + break; Inc(l); end; Dec(l); @@ -340,7 +339,7 @@ begin begin y := Pos(Value[x], Table); if y < 1 then - y := 65; + y := 1; d[n] := y - 1; end; Inc(x); diff --git a/SynaSSL.pas b/synassl.pas.x similarity index 83% rename from SynaSSL.pas rename to synassl.pas.x index d211f4f..76ef390 100644 --- a/SynaSSL.pas +++ b/synassl.pas.x @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.001 | +| Project : Delphree - Synapse | 001.004.000 | |==============================================================================| | Content: SSL support | |==============================================================================| @@ -39,7 +39,8 @@ const DLLSSLName = 'libssl.so'; DLLUtilName = 'libcrypto.so'; {$ELSE} - DLLSSLName = 'ssleay32.dll'; + DLLSSLName = 'libssl32.dll'; + DLLSSLName2 = 'ssleay32.dll'; DLLUtilName = 'libeay32.dll'; {$ENDIF} @@ -57,6 +58,10 @@ const SSL_ERROR_WANT_READ = 2; SSL_ERROR_WANT_WRITE = 3; SSL_ERROR_ZERO_RETURN = 6; + SSL_OP_NO_SSLv2 = $01000000; + SSL_OP_NO_SSLv3 = $02000000; + SSL_OP_NO_TLSv1 = $04000000; + SSL_OP_ALL = $000FFFFF; var SSLLibHandle: Integer = 0; @@ -72,7 +77,11 @@ var SslSetFd : function(s: PSSL; fd: Integer):Integer cdecl = nil; SslMethodV23 : function:PSSL_METHOD cdecl = nil; SslCtxUsePrivateKeyFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil; - SslCtxUseCertificateFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil; + SslCtxUseCertificateChainFile : function(ctx: PSSL_CTX; const _file: PChar):Integer cdecl = nil; + SslCtxCheckPrivateKeyFile : function(ctx: PSSL_CTX):Integer cdecl = nil; + SslCtxSetDefaultPasswdCb : procedure(ctx: PSSL_CTX; cb: Pointer) cdecl = nil; + SslCtxSetDefaultPasswdCbUserdata : procedure(ctx: PSSL_CTX; u: Pointer) cdecl = nil; + SslCtxLoadVerifyLocations : function(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer cdecl = nil; SslNew : function(ctx: PSSL_CTX):PSSL cdecl = nil; SslFree : procedure(ssl: PSSL) cdecl = nil; SslAccept : function(ssl: PSSL):Integer cdecl = nil; @@ -116,6 +125,8 @@ begin SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL)); {$ELSE} SSLLibHandle := LoadLibrary(PChar(DLLSSLName)); + if (SSLLibHandle = 0) then + SSLLibHandle := LoadLibrary(PChar(DLLSSLName2)); SSLUtilHandle := LoadLibrary(PChar(DLLUtilName)); {$ENDIF} if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then @@ -129,7 +140,11 @@ begin SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd')); SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method')); SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_file')); - SslCtxUseCertificateFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_certificate_file')); + SslCtxUseCertificateChainFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_certificate_chain_file')); + SslCtxCheckPrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_check_private_key')); + SslCtxSetDefaultPasswdCb := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_default_passwd_cb')); + SslCtxSetDefaultPasswdCbUserdata := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_default_passwd_cb_userdata')); + SslCtxLoadVerifyLocations := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_load_verify_locations')); SslNew := GetProcAddress(SSLLibHandle, PChar('SSL_new')); SslFree := GetProcAddress(SSLLibHandle, PChar('SSL_free')); SslAccept := GetProcAddress(SSLLibHandle, PChar('SSL_accept')); diff --git a/synautil.pas b/synautil.pas index 86d1b3f..c60f0f8 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.008.001 | +| Project : Delphree - Synapse | 002.011.001 | |==============================================================================| | 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,2001. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | | Portions created by Hernan Sanchez are Copyright (c) 2000. | | All Rights Reserved. | |==============================================================================| @@ -44,6 +44,10 @@ function TimeZone: string; function Rfc822DateTime(t: TDateTime): string; function CDateTime(t: TDateTime): string; function SimpleDateTime(t: TDateTime): string; +function AnsiCDateTime(t: TDateTime): string; +function GetMonthNumber(Value: string): integer; +function GetTimeFromStr(Value: string): TDateTime; +function GetDateMDYFromStr(Value: string): TDateTime; function DecodeRfcDateTime(Value: string): TDateTime; function GetUTTime: TDateTime; function SetUTTime(Newdt: TDateTime): Boolean; @@ -66,6 +70,7 @@ function BinToInt(const Value: string): Integer; function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, Para: string): string; function StringReplace(Value, Search, Replace: string): string; +function RPosEx(const Sub, Value: string; From: integer): Integer; function RPos(const Sub, Value: String): Integer; function Fetch(var Value: string; const Delimiter: string): string; @@ -194,6 +199,18 @@ end; {==============================================================================} +function AnsiCDateTime(t: TDateTime): string; +begin + SaveNames; + try + Result := FormatDateTime('ddd mmm d hh:nn:ss yyyy', t); + finally + RestoreNames; + end; +end; + +{==============================================================================} + function DecodeTimeZone(Value: string; var Zone: integer): Boolean; var x: integer; @@ -281,98 +298,142 @@ end; {==============================================================================} +function GetMonthNumber(Value: string): integer; +var + n: integer; +begin + Result := 0; + Value := Uppercase(Value); + for n := 1 to 12 do + if Value = uppercase(MyMonthNames[n]) then + begin + Result := n; + Break; + end; +end; + +{==============================================================================} + +function GetTimeFromStr(Value: string): TDateTime; +var + SaveSeparator: char; +begin + SaveSeparator := TimeSeparator; + try + TimeSeparator := ':'; + Result := 0; + try + Result := StrToTime(Value); + except + on Exception do ; + end; + finally + TimeSeparator := SaveSeparator; + end; +end; + +{==============================================================================} + +function GetDateMDYFromStr(Value: string): TDateTime; +var + SaveSeparator: char; + SaveFormat: string; +begin + SaveSeparator := DateSeparator; + SaveFormat := ShortDateFormat; + try + DateSeparator := '-'; + ShortDateFormat := 'm-d-y'; + Result := 0; + try + Result := StrToDate(Value); + except + on Exception do ; + end; + finally + ShortDateFormat := SaveFormat; + DateSeparator := SaveSeparator; + end; +end; + +{==============================================================================} + function DecodeRfcDateTime(Value: string): TDateTime; var day, month, year: Word; zone: integer; x: integer; s: string; - SaveSeparator: char; - n: integer; t: TDateTime; begin // ddd, d mmm yyyy hh:mm:ss // ddd, d mmm yy hh:mm:ss // ddd, mmm d yyyy hh:mm:ss // ddd mmm dd hh:mm:ss yyyy -// Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 -// Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 -// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format +// Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +// Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format Result := 0; - SaveSeparator := TimeSeparator; - try - TimeSeparator := ':'; - day := 0; - month := 0; - year := 0; - zone := 0; - Value := StringReplace(Value, ' -', ' #'); - Value := StringReplace(Value, '-', ' '); - Value := StringReplace(Value, ' #', ' -'); - while Value <> '' do + if Value = '' then + Exit; + day := 0; + month := 0; + year := 0; + zone := 0; + Value := StringReplace(Value, ' -', ' #'); + Value := StringReplace(Value, '-', ' '); + Value := StringReplace(Value, ' #', ' -'); + while Value <> '' do + begin + s := Fetch(Value, ' '); + s := uppercase(s); + // timezone + if DecodetimeZone(s, x) then begin - s := Fetch(Value, ' '); - s := uppercase(s); - // timezone - if DecodetimeZone(s, x) then - begin - zone := x; - continue; - end; - x := StrToIntDef(s, 0); - // day or year - if x > 0 then - if (x < 32) and (day = 0) then - begin - day := x; - continue; - end - else - begin - year := x; - if year < 32 then - year := year + 2000; - if year < 1000 then - year := year + 1900; - continue; - end; - // time - if rpos(':', s) > Pos(':', s) then - begin - t := 0; - try - t := StrToTime(s); - except - on Exception do ; - end; - if t <> 0 then - Result := t; - continue; - end; - //timezone daylight saving time - if s = 'DST' then - begin - zone := zone + 60; - continue; - end; - // month - for n := 1 to 12 do - if s = uppercase(MyMonthNames[n]) then - begin - month := n; - break; - end; + zone := x; + continue; end; - Result := Result + Encodedate(year, month, day); - zone := zone - TimeZoneBias; - t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); - if zone < 0 then - t := 0 - t; - Result := Result - t; - finally - TimeSeparator := SaveSeparator; + x := StrToIntDef(s, 0); + // day or year + if x > 0 then + if (x < 32) and (day = 0) then + begin + day := x; + continue; + end + else + begin + year := x; + if year < 32 then + year := year + 2000; + if year < 1000 then + year := year + 1900; + continue; + end; + // time + if rpos(':', s) > Pos(':', s) then + begin + t := GetTimeFromStr(s); + if t <> 0 then + Result := t; + continue; + end; + //timezone daylight saving time + if s = 'DST' then + begin + zone := zone + 60; + continue; + end; + // month + month := GetMonthNumber(s); end; + Result := Result + Encodedate(year, month, day); + zone := zone - TimeZoneBias; + t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); + if zone < 0 then + t := 0 - t; + Result := Result - t; end; {==============================================================================} @@ -836,14 +897,14 @@ end; {==============================================================================} -function RPos(const Sub, Value: String): Integer; +function RPosEx(const Sub, Value: string; From: integer): Integer; var n: Integer; l: Integer; begin result := 0; l := Length(Sub); - for n := Length(Value) - l + 1 downto 1 do + for n := From - l + 1 downto 1 do begin if Copy(Value, n, l) = Sub then begin @@ -855,6 +916,13 @@ end; {==============================================================================} +function RPos(const Sub, Value: String): Integer; +begin + Result := RPosEx(Sub, Value, Length(Value)); +end; + +{==============================================================================} + function Fetch(var Value: string; const Delimiter: string): string; var s: string;