diff --git a/asn1util.pas b/asn1util.pas index a37cf42..9de6970 100644 --- a/asn1util.pas +++ b/asn1util.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.003.006 | +| Project : Ararat Synapse | 001.004.002 | |==============================================================================| | Content: support for ASN.1 BER coding and decoding | |==============================================================================| @@ -45,20 +45,27 @@ |==============================================================================} {$Q-} +{$H+} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} -unit ASN1Util; +unit asn1util; interface uses - SysUtils; + SysUtils, Classes; const + ASN1_BOOL = $01; ASN1_INT = $02; ASN1_OCTSTR = $04; ASN1_NULL = $05; ASN1_OBJID = $06; + ASN1_ENUM = $0a; ASN1_SEQ = $30; + ASN1_SETOF = $31; ASN1_IPADDR = $40; ASN1_COUNTER = $41; ASN1_GAUGE = $42; @@ -77,6 +84,7 @@ function ASNItem(var Start: Integer; const Buffer: string; function MibToId(Mib: string): string; function IdToMib(const Id: string): string; function IntMibToStr(const Value: string): string; +function ASNdump(const Value: string): string; implementation @@ -233,10 +241,11 @@ begin if (Start + ASNSize - 1) > l then Exit; if (ASNType and $20) > 0 then - Result := '$' + IntToHex(ASNType, 2) +// Result := '$' + IntToHex(ASNType, 2) + Result := Copy(Buffer, Start, ASNSize) else case ASNType of - ASN1_INT: + ASN1_INT, ASN1_ENUM, ASN1_BOOL: begin y := 0; neg := False; @@ -297,10 +306,20 @@ begin end; Result := s; end; - else // NULL + ASN1_NULL: + begin + Result := ''; + Start := Start + ASNSize; + end; + else // unknown begin - Result := ''; - Start := Start + ASNSize; + for n := 1 to ASNSize do + begin + c := Char(Buffer[Start]); + Inc(Start); + s := s + c; + end; + Result := s; end; end; end; @@ -372,6 +391,75 @@ begin Result := IntToStr(y); end; +{==============================================================================} +function ASNdump(const Value: string): string; +var + i, at, x, n: integer; + s, indent: string; + il: TStringList; +begin + il := TStringList.Create; + try + Result := ''; + i := 1; + indent := ''; + while i < Length(Value) do + begin + for n := il.Count - 1 downto 0 do + begin + x := StrToIntDef(il[n], 0); + if x <= i then + begin + il.Delete(n); + Delete(indent, 1, 2); + end; + end; + s := ASNItem(i, Value, at); + Result := Result + indent + '$' + IntToHex(at, 2); + if (at and $20) > 0 then + begin + x := Length(s); + Result := Result + ' constructed: length ' + IntToStr(x); + indent := indent + ' '; + il.Add(IntToStr(x + i - 1)); + end + else + begin + case at of + ASN1_BOOL: + Result := Result + ' BOOL: '; + ASN1_INT: + Result := Result + ' INT: '; + ASN1_ENUM: + Result := Result + ' ENUM: '; + ASN1_COUNTER: + Result := Result + ' COUNTER: '; + ASN1_GAUGE: + Result := Result + ' GAUGE: '; + ASN1_TIMETICKS: + Result := Result + ' TIMETICKS: '; + ASN1_OCTSTR: + Result := Result + ' OCTSTR: '; + ASN1_OPAQUE: + Result := Result + ' OPAQUE: '; + ASN1_OBJID: + Result := Result + ' OBJID: '; + ASN1_IPADDR: + Result := Result + ' IPADDR: '; + ASN1_NULL: + Result := Result + ' NULL: '; + else // other + Result := Result + ' unknown: '; + end; + Result := Result + s; + end; + Result := Result + #$0d + #$0a; + end; + finally + il.Free; + end; +end; + {==============================================================================} end. diff --git a/blcksock.pas b/blcksock.pas index 4681ce6..7692d03 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 007.002.014 | +| Project : Ararat Synapse | 007.009.001 | |==============================================================================| | Content: Library base | |==============================================================================| @@ -47,8 +47,6 @@ Special thanks to Gregor Ibic for good inspiration about SSL programming. } -{$Q-} - {$DEFINE ONCEWINSOCK} {Note about define ONCEWINSOCK: If you remove this compiler directive, then socket interface is loaded and @@ -61,12 +59,21 @@ count of created and destroyed sockets. It eliminate possible small resource leak on Windows systems too. } +//{$DEFINE RAISEEXCEPT} +{When you enable this define, then is Raiseexcept property is on by default +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$IFDEF VER125} {$DEFINE BCB} {$ENDIF} {$IFDEF BCB} {$ObjExportAll On} {$ENDIF} +{$Q-} +{$H+} unit blcksock; @@ -75,15 +82,18 @@ interface uses SysUtils, Classes, {$IFDEF LINUX} - Libc, kernelioctl, + {$IFDEF FPC} + synafpc, + {$ENDIF} + Libc, {$ELSE} Windows, {$ENDIF} - synsock, SynaUtil, SynaCode, SynaSSL; + synsock, synautil, synacode, synassl; const - SynapseRelease = '31'; + SynapseRelease = '32'; cLocalhost = '127.0.0.1'; cAnyHost = '0.0.0.0'; @@ -95,6 +105,7 @@ const CR = #$0d; LF = #$0a; CRLF = CR + LF; + c64k = 65536; type @@ -121,7 +132,8 @@ type HR_Accept, HR_ReadCount, HR_WriteCount, - HR_Wait + HR_Wait, + HR_Error ); THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason; @@ -142,13 +154,12 @@ type ST_Socks4 ); - TSynaSin = record - usedip6: Boolean; - isip4: Boolean; - ip4: TSockAddrIn; - isip6: Boolean; - ip6: TSockAddrIn6; - end; + TSSLType = ( + LT_SSLv2, + LT_SSLv3, + LT_TLSv1, + LT_all + ); TSynaOptionType = ( SOT_Linger, @@ -178,8 +189,8 @@ type FOnWriteFilter: THookDataFilter; FOnCreateSocket: THookCreateSocket; FWsaData: TWSADATA; - FLocalSin: TSynaSin; - FRemoteSin: TSynaSin; + FLocalSin: TVarSin; + FRemoteSin: TVarSin; FBuffer: string; FRaiseExcept: Boolean; FNonBlockMode: Boolean; @@ -199,6 +210,8 @@ type FDelayedOptions: TList; FInterPacketTimeout: Boolean; FFDSet: TFDSet; + FRecvCounter: Integer; + FSendCounter: Integer; function GetSizeRecvBuffer: Integer; procedure SetSizeRecvBuffer(Size: Integer); function GetSizeSendBuffer: Integer; @@ -207,8 +220,8 @@ type procedure SetTTL(TTL: integer); function GetTTL:integer; function IsNewApi: Boolean; - procedure SetFamily(Value: TSocketFamily); - procedure SetSocket(Value: TSocket); + procedure SetFamily(Value: TSocketFamily); virtual; + procedure SetSocket(Value: TSocket); virtual; protected FSocket: TSocket; FLastError: Integer; @@ -216,10 +229,10 @@ type procedure SetDelayedOption(Value: TSynaOption); procedure DelayedOption(Value: TSynaOption); procedure ProcessDelayedOptions; - procedure InternalCreateSocket(Sin: TSynaSin); - procedure SetSin(var Sin: TSynaSin; IP, Port: string); - function GetSinIP(Sin: TSynaSin): string; - function GetSinPort(Sin: TSynaSin): Integer; + procedure InternalCreateSocket(Sin: TVarSin); + procedure SetSin(var Sin: TVarSin; IP, Port: string); + function GetSinIP(Sin: TVarSin): string; + function GetSinPort(Sin: TVarSin): Integer; procedure DoStatus(Reason: THookSocketReason; const Value: string); procedure DoReadFilter(Buffer: Pointer; var Length: Integer); procedure DoWriteFilter(Buffer: Pointer; var Length: Integer); @@ -233,11 +246,14 @@ type procedure CreateSocket; procedure CreateSocketByName(const Value: String); procedure CloseSocket; virtual; + procedure AbortSocket; procedure Bind(IP, Port: string); procedure Connect(IP, Port: string); virtual; function SendBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; procedure SendByte(Data: Byte); virtual; procedure SendString(const Data: string); virtual; + procedure SendBlock(const Data: string); virtual; + procedure SendStream(const Stream: TStream); virtual; function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; function RecvBufferEx(Buffer: Pointer; Length: Integer; Timeout: Integer): Integer; virtual; @@ -246,10 +262,13 @@ type function RecvString(Timeout: Integer): string; virtual; function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual; function RecvPacket(Timeout: Integer): string; virtual; + function RecvBlock(Timeout: Integer): string; virtual; + procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; function PeekByte(Timeout: Integer): Byte; virtual; function WaitingData: Integer; virtual; function WaitingDataEx: Integer; + procedure Purge; procedure SetLinger(Enable: Boolean; Linger: Integer); procedure GetSinLocal; procedure GetSinRemote; @@ -284,6 +303,9 @@ type function GetSocketType: integer; Virtual; function GetSocketProtocol: integer; Virtual; + property WSAData: TWSADATA read FWsaData; + property LocalSin: TVarSin read FLocalSin write FLocalSin; + property RemoteSin: TVarSin read FRemoteSin write FRemoteSin; published class function GetErrorDesc(ErrorCode: Integer): string; property Socket: TSocket read FSocket write SetSocket; @@ -293,7 +315,6 @@ type property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer; property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer; - property WSAData: TWSADATA read FWsaData; property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; @@ -305,8 +326,8 @@ type property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4; property IP6used: Boolean read FIP6used; property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; - property LocalSin: TSynaSin read FLocalSin write FLocalSin; - property RemoteSin: TSynaSin read FRemoteSin write FRemoteSin; + property RecvCounter: Integer read FRecvCounter; + property SendCounter: Integer read FSendCounter; property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter; property OnWriteFilter: THookDataFilter read FOnWriteFilter write FOnWriteFilter; @@ -343,6 +364,7 @@ type property SocksPort: string read FSocksPort write FSocksPort; property SocksUsername: string read FSocksUsername write FSocksUsername; property SocksPassword: string read FSocksPassword write FSocksPassword; + property SocksTimeout: integer read FSocksTimeout write FSocksTimeout; property UsingSocks: Boolean read FUsingSocks; property SocksResolver: Boolean read FSocksResolver write FSocksResolver; property SocksLastError: integer read FSocksLastError; @@ -363,6 +385,7 @@ type FSSLLastError: integer; FSSLLastErrorDesc: string; FSSLverifyCert: Boolean; + FSSLType: TSSLType; FHTTPTunnelIP: string; FHTTPTunnelPort: string; FHTTPTunnel: Boolean; @@ -370,10 +393,12 @@ type FHTTPTunnelRemotePort: string; FHTTPTunnelUser: string; FHTTPTunnelPass: string; + FHTTPTunnelTimeout: integer; procedure SetSslEnabled(Value: Boolean); function SetSslKeys: boolean; procedure SocksDoConnect(IP, Port: string); procedure HTTPTunnelDoConnect(IP, Port: string); + function GetSSLLoaded: Boolean; public constructor Create; procedure CloseSocket; override; @@ -393,14 +418,22 @@ type function SSLGetSSLVersion: string; function SSLGetPeerSubject: string; function SSLGetPeerIssuer: string; + function SSLGetPeerName: string; function SSLGetPeerSubjectHash: Cardinal; function SSLGetPeerIssuerHash: Cardinal; function SSLGetPeerFingerprint: string; + function SSLGetCertInfo: string; + function SSLGetCipherName: string; + function SSLGetCipherBits: integer; + function SSLGetCipherAlgBits: integer; + function SSLGetVerifyCert: integer; function SSLCheck: Boolean; function GetSocketType: integer; override; function GetSocketProtocol: integer; override; published + property SSLLoaded: Boolean read GetSslLoaded; property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled; + property SSLType: TSSLType read FSSLType write FSSLType; property SSLBypass: Boolean read FSslBypass write FSslBypass; property SSLPassword: string read FSSLPassword write FSSLPassword; property SSLCiphers: string read FSSLCiphers write FSSLCiphers; @@ -415,9 +448,17 @@ type property HTTPTunnel: Boolean read FHTTPTunnel; property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser; property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass; + property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout; end; - TUDPBlockSocket = class(TSocksBlockSocket) + TDgramBlockSocket = class(TSocksBlockSocket) + public + procedure Connect(IP, Port: string); override; + function SendBuffer(Buffer: Pointer; Length: Integer): Integer; override; + function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; override; + end; + + TUDPBlockSocket = class(TDgramBlockSocket) protected FSocksControlSock: TTCPBlockSocket; function UdpAssociation: Boolean; @@ -426,9 +467,6 @@ type public destructor Destroy; override; procedure EnableBroadcast(Value: Boolean); - procedure Connect(IP, Port: string); override; - function SendBuffer(Buffer: Pointer; Length: Integer): Integer; override; - function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; override; function SendBufferTo(Buffer: Pointer; Length: Integer): Integer; override; function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; override; procedure AddMulticast(MCastIP:string); @@ -440,7 +478,7 @@ type property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL; end; - TICMPBlockSocket = class(TBlockSocket) + TICMPBlockSocket = class(TDgramBlockSocket) public function GetSocketType: integer; override; function GetSocketProtocol: integer; override; @@ -504,6 +542,9 @@ begin inherited Create; FDelayedOptions := TList.Create; FRaiseExcept := False; +{$IFDEF RAISEEXCEPT} + FRaiseExcept := True; +{$ENDIF} FSocket := INVALID_SOCKET; FBuffer := ''; FLastCR := False; @@ -521,6 +562,8 @@ begin FIP6used := False; FPreferIP4 := True; FInterPacketTimeout := True; + FRecvCounter := 0; + FSendCounter := 0; {$IFDEF ONCEWINSOCK} FWsaData := WsaDataOnce; {$ELSE} @@ -541,6 +584,7 @@ end; destructor TBlockSocket.Destroy; var n: integer; + p: PSynaOption; begin CloseSocket; {$IFNDEF ONCEWINSOCK} @@ -548,7 +592,10 @@ begin DestroySocketInterface; {$ENDIF} for n := FDelayedOptions.Count - 1 downto 0 do - Dispose(PSynaOption(FDelayedOptions[n])); + begin + p := PSynaOption(FDelayedOptions[n]); + Dispose(p); + end; FDelayedOptions.Free; inherited Destroy; end; @@ -666,7 +713,7 @@ begin FDelayedOptions.Clear; end; -procedure TBlockSocket.SetSin(var Sin: TSynaSin; IP, Port: string); +procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string); type pu_long = ^u_long; var @@ -677,12 +724,10 @@ var Addr: PAddrInfo; AddrNext: PAddrInfo; r: integer; + Sin4, Sin6: TVarSin; begin DoStatus(HR_ResolvingBegin, IP + ':' + Port); FillChar(Sin, Sizeof(Sin), 0); - Sin.isip4 := False; - Sin.isip6 := False; - Sin.usedip6 := False; //for prelimitary IP6 support try fake Family by given IP if SockWship6Api and (FFamily = SF_Any) then begin @@ -701,26 +746,25 @@ begin begin SynSockCS.Enter; try - Sin.isip4 := True; - Sin.ip4.sin_family := AF_INET; + Sin.sin_family := AF_INET; ProtoEnt := synsock.GetProtoByNumber(GetSocketProtocol); ServEnt := nil; if ProtoEnt <> nil then ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); if ServEnt = nil then - Sin.ip4.sin_port := synsock.htons(StrToIntDef(Port, 0)) + Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) else - Sin.ip4.sin_port := ServEnt^.s_port; + Sin.sin_port := ServEnt^.s_port; if IP = cBroadcast then - Sin.ip4.sin_addr.s_addr := u_long(INADDR_BROADCAST) + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) else begin - Sin.ip4.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); - if Sin.ip4.sin_addr.s_addr = u_long(INADDR_NONE) then + Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then begin HostEnt := synsock.GetHostByName(PChar(IP)); if HostEnt <> nil then - Sin.ip4.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); end; end; finally @@ -731,6 +775,8 @@ begin begin Addr := nil; try + FillChar(Sin4, Sizeof(Sin4), 0); + FillChar(Sin6, Sizeof(Sin6), 0); FillChar(Hints, Sizeof(Hints), 0); //if socket exists, then use their type, else use users selection if FSocket = INVALID_SOCKET then @@ -774,23 +820,25 @@ begin AddrNext := Addr; while not (AddrNext = nil) do begin - if not(Sin.isip4) and (AddrNext^.ai_family = AF_INET) then - begin - Move(AddrNext^.ai_addr^, Sin.IP4, SizeOf(Sin.IP4)); - sin.isip4 := True; - end; - if not(Sin.isip6) and (AddrNext^.ai_family = AF_INET6) then - begin - Move(AddrNext^.ai_addr^, Sin.IP6, SizeOf(Sin.IP6)); - sin.isip6 := True; - end; + if not(Sin4.sin_family = AF_INET) and (AddrNext^.ai_family = AF_INET) then + Move(AddrNext^.ai_addr^, Sin4, AddrNext^.ai_addrlen); + if not(Sin6.sin_family = AF_INET6) and (AddrNext^.ai_family = AF_INET6) then + Move(AddrNext^.ai_addr^, Sin6, AddrNext^.ai_addrlen); AddrNext := AddrNext^.ai_next; end; - if Sin.isip4 or Sin.isip6 then + if (Sin4.sin_family = AF_INET) and (Sin6.sin_family = AF_INET6) then + begin if FPreferIP4 then - Sin.usedip6 := not(Sin.isip4) + Sin := Sin4 else - Sin.usedip6 := Sin.isip6; + Sin := Sin6; + end + else + begin + sin := sin4; + if (Sin6.sin_family = AF_INET6) then + sin := sin6; + end; end; finally if Assigned(Addr) then @@ -800,7 +848,7 @@ begin DoStatus(HR_ResolvingEnd, IP + ':' + Port); end; -function TBlockSocket.GetSinIP(Sin: TSynaSin): string; +function TBlockSocket.GetSinIP(Sin: TVarSin): string; var p: PChar; host, serv: string; @@ -810,7 +858,7 @@ begin Result := ''; if not IsNewApi then begin - p := synsock.inet_ntoa(Sin.ip4.sin_addr); + p := synsock.inet_ntoa(Sin.sin_addr); if p <> nil then Result := p; end @@ -820,42 +868,41 @@ begin servlen := NI_MAXSERV; setlength(host, hostlen); setlength(serv, servlen); - if FIP6Used then - r := getnameinfo(@sin.ip6, SizeOf(sin.ip6), PChar(host), hostlen, - PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV) - else - r := getnameinfo(@sin.ip4, SizeOf(sin.ip4), PChar(host), hostlen, - PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + r := getnameinfo(@sin, SizeOfVarSin(sin), PChar(host), hostlen, + PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); if r = 0 then Result := PChar(host); end; end; -function TBlockSocket.GetSinPort(Sin: TSynaSin): Integer; +function TBlockSocket.GetSinPort(Sin: TVarSin): Integer; begin - if FIP6Used then - Result := synsock.ntohs(Sin.ip6.sin6_port) + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) else - Result := synsock.ntohs(Sin.ip4.sin_port); + Result := synsock.ntohs(Sin.sin_port); end; procedure TBlockSocket.CreateSocket; var - sin: TSynaSin; + sin: TVarSin; begin //dummy for SF_Any Family mode FLastError := 0; if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then begin FillChar(Sin, Sizeof(Sin), 0); - sin.usedip6 := FFamily = SF_IP6; + if FFamily = SF_IP6 then + sin.sin_family := AF_INET6 + else + sin.sin_family := AF_INET; InternalCreateSocket(Sin); end; end; procedure TBlockSocket.CreateSocketByName(const Value: String); var - sin: TSynaSin; + sin: TVarSin; begin FLastError := 0; if FSocket = INVALID_SOCKET then @@ -865,18 +912,17 @@ begin end; end; -procedure TBlockSocket.InternalCreateSocket(Sin: TSynaSin); +procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin); begin + FRecvCounter := 0; + FSendCounter := 0; FLastError := 0; if FSocket = INVALID_SOCKET then begin FBuffer := ''; FBinded := False; - FIP6Used := Sin.usedip6; - if FIP6Used then - FSocket := synsock.Socket(PF_INET6, GetSocketType, GetSocketProtocol) - else - FSocket := synsock.Socket(PF_INET, GetSocketType, GetSocketProtocol); + FIP6Used := Sin.sin_family = AF_INET6; + FSocket := synsock.Socket(Sin.sin_family, GetSocketType, GetSocketProtocol); if FSocket = INVALID_SOCKET then FLastError := synsock.WSAGetLastError; FD_ZERO(FFDSet); @@ -892,13 +938,22 @@ begin end; procedure TBlockSocket.CloseSocket; +begin + AbortSocket; +end; + +procedure TBlockSocket.AbortSocket; var n: integer; + p: PSynaOption; begin synsock.CloseSocket(FSocket); FSocket := INVALID_SOCKET; for n := FDelayedOptions.Count - 1 downto 0 do - Dispose(PSynaOption(FDelayedOptions[n])); + begin + p := PSynaOption(FDelayedOptions[n]); + Dispose(p); + end; FDelayedOptions.Clear; FFamily := FFamilySave; FLastError := 0; @@ -907,7 +962,7 @@ end; procedure TBlockSocket.Bind(IP, Port: string); var - Sin: TSynaSin; + Sin: TVarSin; begin FLastError := 0; if (FSocket <> INVALID_SOCKET) @@ -915,14 +970,8 @@ begin begin SetSin(Sin, IP, Port); if FSocket = INVALID_SOCKET then - begin InternalCreateSocket(Sin); - FIP6Used := Sin.usedip6; - end; - if FIP6Used then - SockCheck(synsock.Bind(FSocket, @Sin.ip6, SizeOf(Sin.ip6))) - else - SockCheck(synsock.Bind(FSocket, @Sin.ip4, SizeOf(Sin.ip4))); + SockCheck(synsock.Bind(FSocket, @Sin, SizeOfVarSin(Sin))); GetSinLocal; FBuffer := ''; FBinded := True; @@ -933,18 +982,12 @@ end; procedure TBlockSocket.Connect(IP, Port: string); var - Sin: TSynaSin; + Sin: TVarSin; begin SetSin(Sin, IP, Port); if FSocket = INVALID_SOCKET then - begin InternalCreateSocket(Sin); - FIP6Used := Sin.usedip6; - end; - if FIP6Used then - SockCheck(synsock.Connect(FSocket, @Sin.ip6, SizeOf(Sin.ip6))) - else - SockCheck(synsock.Connect(FSocket, @Sin.ip4, SizeOf(Sin.ip4))); + SockCheck(synsock.Connect(FSocket, @Sin, SizeOfVarSin(Sin))); GetSins; FBuffer := ''; FLastCR := False; @@ -958,21 +1001,8 @@ var Len: Integer; begin FillChar(FLocalSin, Sizeof(FLocalSin), 0); - FLocalSin.isip4 := False; - FLocalSin.isip6 := False; - FLocalSin.usedip6 := False; - if FIP6Used then - begin - Len := SizeOf(FLocalSin.ip6); - synsock.GetSockName(FSocket, @FLocalSin.ip6, Len); - FLocalSin.isip6 := True; - end - else - begin - Len := SizeOf(FLocalSin.ip4); - synsock.GetSockName(FSocket, @FLocalSin.ip4, Len); - FLocalSin.isip4 := True; - end; + Len := SizeOf(FLocalSin); + synsock.GetSockName(FSocket, @FLocalSin, Len); end; procedure TBlockSocket.GetSinRemote; @@ -980,21 +1010,8 @@ var Len: Integer; begin FillChar(FRemoteSin, Sizeof(FRemoteSin), 0); - FRemoteSin.isip4 := False; - FRemoteSin.isip6 := False; - FRemoteSin.usedip6 := False; - if FIP6Used then - begin - Len := SizeOf(FRemoteSin.ip6); - synsock.GetPeerName(FSocket, @FRemoteSin.ip6, Len); - FRemoteSin.isip6 := True; - end - else - begin - Len := SizeOf(FRemoteSin.ip4); - synsock.GetPeerName(FSocket, @FRemoteSin.ip4, Len); - FRemoteSin.isip4 := True; - end; + Len := SizeOf(FRemoteSin); + synsock.GetPeerName(FSocket, @FRemoteSin, Len); end; procedure TBlockSocket.GetSins; @@ -1037,6 +1054,7 @@ begin Result := synsock.Send(FSocket, Buffer^, Length, MSG_NOSIGNAL); SockCheck(Result); ExceptCheck; + Inc(FSendCounter, Result); DoStatus(HR_WriteCount, IntToStr(Result)); end; @@ -1050,6 +1068,42 @@ begin SendBuffer(PChar(Data), Length(Data)); end; +procedure TBlockSocket.SendBlock(const Data: string); +var + x: integer; +begin + x := Length(Data); + SendBuffer(@x, SizeOf(x)); + SendString(Data); +end; + +procedure TBlockSocket.SendStream(const Stream: TStream); +var + si: integer; + x, y, yr: integer; + s: string; +begin + si := Stream.Size - Stream.Position; + SendBuffer(@si, SizeOf(si)); + x := 0; + while x < si do + begin + y := si - x; + if y > c64k then + y := c64k; + Setlength(s, c64k); + yr := Stream.read(s, y); + if yr > 0 then + begin + SetLength(s, yr); + SendString(s); + Inc(x, yr); + end + else + break; + end; +end; + function TBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; begin LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); @@ -1059,6 +1113,7 @@ begin else SockCheck(Result); ExceptCheck; + Inc(FRecvCounter, Result); DoStatus(HR_ReadCount, IntToStr(Result)); DoReadFilter(Buffer, Result); end; @@ -1259,6 +1314,43 @@ begin Result := s; end; +function TBlockSocket.RecvBlock(Timeout: Integer): string; +var + x: integer; +begin + Result := ''; + RecvBufferEx(@x, SizeOf(x), Timeout); + if FLastError = 0 then + Result := RecvBufferStr(x, Timeout); +end; + +procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer); +var + x: integer; + s: string; + n: integer; +begin + RecvBufferEx(@x, SizeOf(x), Timeout); + if FLastError = 0 then + begin + for n := 1 to (x div c64k) do + begin + s := RecvBufferStr(c64k, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(s, c64k); + end; + n := x mod c64k; + if n > 0 then + begin + s := RecvBufferStr(n, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(s, n); + end; + end; +end; + function TBlockSocket.PeekBuffer(Buffer: Pointer; Length: Integer): Integer; begin Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL); @@ -1299,17 +1391,20 @@ end; procedure TBlockSocket.ExceptCheck; var e: ESynapseError; - s: string; begin - FLastErrorDesc := ''; - if FRaiseExcept and (LastError <> 0) and (LastError <> WSAEINPROGRESS) + FLastErrorDesc := GetErrorDesc(FLastError); + if (LastError <> 0) and (LastError <> WSAEINPROGRESS) and (LastError <> WSAEWOULDBLOCK) then begin - FLastErrorDesc := GetErrorDesc(LastError); - e := ESynapseError.CreateFmt('Synapse TCP/IP Socket error %d: %s', [LastError, s]); - e.ErrorCode := LastError; - e.ErrorMessage := FLastErrorDesc; - raise e; + DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc); + if FRaiseExcept then + begin + e := ESynapseError.CreateFmt('Synapse TCP/IP Socket error %d: %s', + [FLastError, FLastErrorDesc]); + e.ErrorCode := FLastError; + e.ErrorMessage := FLastErrorDesc; + raise e; + end; end; end; @@ -1317,8 +1412,9 @@ function TBlockSocket.WaitingData: Integer; var x: Integer; begin - synsock.IoctlSocket(FSocket, FIONREAD, u_long(x)); - Result := x; + Result := 0; + if synsock.IoctlSocket(FSocket, FIONREAD, u_long(x)) = 0 then + Result := x; end; function TBlockSocket.WaitingDataEx: Integer; @@ -1329,6 +1425,13 @@ begin Result := WaitingData; end; +procedure TBlockSocket.Purge; +begin + repeat + RecvPacket(0); + until FLastError <> 0; + FLastError := 0; +end; procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); var @@ -1474,9 +1577,9 @@ begin if ProtoEnt <> nil then ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); if ServEnt = nil then - Result := synsock.htons(StrToIntDef(Port, 0)) + Result := StrToIntDef(Port, 0) else - Result := ServEnt^.s_port; + Result := synsock.htons(ServEnt^.s_port); finally SynSockCS.Leave; end; @@ -1646,18 +1749,11 @@ var Len: Integer; begin LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); - if FIP6Used then - begin - Len := SizeOf(FRemoteSin.ip6); - Result := synsock.SendTo(FSocket, Buffer^, Length, 0, @FRemoteSin.ip6, Len); - end - else - begin - Len := SizeOf(FRemoteSin.ip4); - Result := synsock.SendTo(FSocket, Buffer^, Length, 0, @FRemoteSin.ip4, Len); - end; + Len := SizeOfVarSin(FRemoteSin); + Result := synsock.SendTo(FSocket, Buffer^, Length, 0, @FRemoteSin, Len); SockCheck(Result); ExceptCheck; + Inc(FSendCounter, Result); DoStatus(HR_WriteCount, IntToStr(Result)); end; @@ -1666,18 +1762,11 @@ var Len: Integer; begin LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - if FIP6Used then - begin - Len := SizeOf(FRemoteSin.ip6); - Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, @FRemoteSin.ip6, Len); - end - else - begin - Len := SizeOf(FRemoteSin.ip4); - Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, @FRemoteSin.ip4, Len); - end; + Len := SizeOf(FRemoteSin); + Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, @FRemoteSin, Len); SockCheck(Result); ExceptCheck; + Inc(FRecvCounter, Result); DoStatus(HR_ReadCount, IntToStr(Result)); end; @@ -1828,10 +1917,13 @@ end; procedure TBlockSocket.SetSocket(Value: TSocket); begin + FRecvCounter := 0; + FSendCounter := 0; FSocket := Value; FD_ZERO(FFDSet); FD_SET(FSocket, FFDSet); GetSins; + FIP6Used := FRemoteSin.sin_family = AF_INET6; end; function TBlockSocket.StrToIP6(const value: string): TSockAddrIn6; @@ -1939,7 +2031,7 @@ class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; begin case ErrorCode of 0: - Result := 'OK'; + Result := ''; WSAEINTR: {10004} Result := 'Interrupted system call'; WSAEBADF: {10009} @@ -2054,7 +2146,7 @@ begin inherited Create; FSocksIP:= ''; FSocksPort:= '1080'; - FSocksTimeout:= 300000; + FSocksTimeout:= 60000; FSocksUsername:= ''; FSocksPassword:= ''; FUsingSocks := False; @@ -2157,7 +2249,7 @@ begin Buf := RecvBufferStr(8, FSocksTimeout); if FLastError <> 0 then Exit; - if Buf[1] <> #4 then + if Buf[1] <> #0 then Exit; FSocksLastError := Ord(Buf[2]); end @@ -2188,7 +2280,7 @@ begin Exit; FSocksLastError := Ord(Buf[2]); end; - if FSocksLastError <> 0 then + if ((FSocksLastError <> 0) and (FSocksLastError <> 90)) then Exit; SocksDecode(Buf); Result := True; @@ -2334,6 +2426,26 @@ end; {======================================================================} +procedure TDgramBlockSocket.Connect(IP, Port: string); +begin + SetRemoteSin(IP, Port); + InternalCreateSocket(FRemoteSin); + FBuffer := ''; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +function TDgramBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; +begin + Result := RecvBufferFrom(Buffer, Length); +end; + +function TDgramBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; +begin + Result := SendBufferTo(Buffer, Length); +end; + +{======================================================================} + destructor TUDPBlockSocket.Destroy; begin if Assigned(FSocksControlSock) then @@ -2350,24 +2462,6 @@ begin DelayedOption(d); end; -procedure TUDPBlockSocket.Connect(IP, Port: string); -begin - SetRemoteSin(IP, Port); - InternalCreateSocket(FRemoteSin); - FBuffer := ''; - DoStatus(HR_Connect, IP + ':' + Port); -end; - -function TUDPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; -begin - Result := RecvBufferFrom(Buffer, Length); -end; - -function TUDPBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; -begin - Result := SendBufferTo(Buffer, Length); -end; - function TUDPBlockSocket.UdpAssociation: Boolean; var b: Boolean; @@ -2388,6 +2482,8 @@ begin if not FBinded then Bind(cAnyHost, cAnyPort); //open control TCP connection to SOCKS + FSocksControlSock.FSocksUsername := FSocksUsername; + FSocksControlSock.FSocksPassword := FSocksPassword; b := FSocksControlSock.SocksOpen; if b then b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort)); @@ -2563,6 +2659,7 @@ begin FSSLLastError := 0; FSSLLastErrorDesc := ''; FSSLverifyCert := False; + FSSLType := LT_all; FHTTPTunnelIP := ''; FHTTPTunnelPort := ''; FHTTPTunnel := False; @@ -2570,6 +2667,7 @@ begin FHTTPTunnelRemotePort := ''; FHTTPTunnelUser := ''; FHTTPTunnelPass := ''; + FHTTPTunnelTimeout := 30000; end; procedure TTCPBlockSocket.CloseSocket; @@ -2579,9 +2677,7 @@ begin if FSocket <> INVALID_SOCKET then begin Synsock.Shutdown(FSocket, 1); - repeat - RecvPacket(0); - until FLastError <> 0; + Purge; end; inherited CloseSocket; end; @@ -2644,16 +2740,8 @@ begin end else begin - if FIP6used then - begin - Len := SizeOf(FRemoteSin.ip6); - Result := synsock.Accept(FSocket, @FRemoteSin.ip6, Len); - end - else - begin - Len := SizeOf(FRemoteSin.ip4); - Result := synsock.Accept(FSocket, @FRemoteSin.ip4, Len); - end; + Len := SizeOf(FRemoteSin); + Result := synsock.Accept(FSocket, @FRemoteSin, Len); SockCheck(Result); end; ExceptCheck; @@ -2661,6 +2749,8 @@ begin end; procedure TTCPBlockSocket.Connect(IP, Port: string); +var + x: integer; begin if FSocksIP <> '' then SocksDoConnect(IP, Port) @@ -2670,7 +2760,14 @@ begin else inherited Connect(IP, Port); if FSslEnabled then - SSLDoConnect; + if FLastError = 0 then + SSLDoConnect + else + begin + x := FLastError; + SSLEnabled := False; + FLastError := x; + end; end; procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); @@ -2716,7 +2813,7 @@ begin EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); SendString(CRLF); repeat - s := RecvTerminated(30000, #$0a); + s := RecvTerminated(FHTTPTunnelTimeout, #$0a); if FLastError <> 0 then Break; if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then @@ -2733,6 +2830,8 @@ begin end; procedure TTCPBlockSocket.SSLDoConnect; +var + x: integer; begin FLastError := 0; if not FSSLEnabled then @@ -2744,16 +2843,34 @@ begin SSLCheck; end; if (FLastError = 0) then - if sslconnect(FSsl) < 1 then + begin + x := sslconnect(FSsl); + if x < 1 then + begin FLastError := WSASYSNOTREADY; + SSLcheck; + end; + end; + if FLastError <> 0 then + begin + x := FLastError; + SSLEnabled := False; + FLastError := x; + end; ExceptCheck; end; procedure TTCPBlockSocket.SSLDoShutdown; +var + x: integer; begin FLastError := 0; - if sslshutdown(FSsl) < 0 then - FLastError := WSASYSNOTREADY; + if assigned(FSsl) then + begin + x := sslshutdown(FSsl); + if x = 0 then + sslshutdown(FSsl); + end; SSLEnabled := False; ExceptCheck; end; @@ -2812,9 +2929,20 @@ begin end; end; +function TTCPBlockSocket.GetSSLLoaded: Boolean; +begin + Result := IsSSLLoaded; +end; + function TTCPBlockSocket.SetSslKeys: boolean; begin - Result := True; + if not assigned(FCtx) then + begin + Result := False; + Exit; + end + else + Result := True; if FSSLCertificateFile <> '' then if SslCtxUseCertificateChainFile(FCtx, PChar(FSSLCertificateFile)) <> 1 then begin @@ -2850,11 +2978,18 @@ begin FSSLLastError := 0; if InitSSLInterface then begin - SslLibraryInit; - SslLoadErrorStrings; err := False; Fctx := nil; - Fctx := SslCtxNew(SslMethodV23); + case FSSLType of + LT_SSLv2: + Fctx := SslCtxNew(SslMethodV2); + LT_SSLv3: + Fctx := SslCtxNew(SslMethodV3); + LT_TLSv1: + Fctx := SslCtxNew(SslMethodTLSV1); + LT_all: + Fctx := SslCtxNew(SslMethodV23); + end; if Fctx = nil then begin SSLCheck; @@ -2884,23 +3019,19 @@ begin end; end; end; - if err then - DestroySSLInterface - else - FSslEnabled := True; + FSslEnabled := not err; end else - begin - DestroySSLInterface; FlastError := WSAEPROTONOSUPPORT; - end; end else begin FBuffer := ''; sslfree(Fssl); + Fssl := nil; SslCtxFree(Fctx); - DestroySSLInterface; + Fctx := nil; + ErrRemoveState(0); FSslEnabled := False; end; ExceptCheck; @@ -2923,6 +3054,7 @@ begin if (err <> 0) then FLastError := WSASYSNOTREADY; ExceptCheck; + Inc(FRecvCounter, Result); DoStatus(HR_ReadCount, IntToStr(Result)); DoReadFilter(Buffer, Result); end @@ -2948,6 +3080,7 @@ begin if (err <> 0) then FLastError := WSASYSNOTREADY; ExceptCheck; + Inc(FSendCounter, Result); DoStatus(HR_WriteCount, IntToStr(Result)); end else @@ -2955,6 +3088,8 @@ begin end; function TTCPBlockSocket.SSLAcceptConnection: Boolean; +var + x: integer; begin FLastError := 0; if not FSSLEnabled then @@ -2968,13 +3103,22 @@ begin if (FLastError = 0) then if sslAccept(FSsl) < 1 then FLastError := WSASYSNOTREADY; + if FLastError <> 0 then + begin + x := FLastError; + SSLEnabled := False; + FLastError := x; + end; ExceptCheck; Result := FLastError = 0; end; function TTCPBlockSocket.SSLGetSSLVersion: string; begin - Result := SSlGetVersion(FSsl); + if not assigned(FSsl) then + Result := '' + else + Result := SSlGetVersion(FSsl); end; function TTCPBlockSocket.SSLGetPeerSubject: string; @@ -2982,17 +3126,36 @@ var cert: PX509; s: string; begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; cert := SSLGetPeerCertificate(Fssl); setlength(s, 4096); Result := SslX509NameOneline(SslX509GetSubjectName(cert), PChar(s), length(s)); SslX509Free(cert); end; +function TTCPBlockSocket.SSLGetPeerName: string; +var + s: string; +begin + s := SSLGetPeerSubject; + s := SeparateRight(s, '/CN='); + Result := SeparateLeft(s, '/'); +end; + function TTCPBlockSocket.SSLGetPeerIssuer: string; var cert: PX509; s: string; begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; cert := SSLGetPeerCertificate(Fssl); setlength(s, 4096); Result := SslX509NameOneline(SslX509GetIssuerName(cert), PChar(s), length(s)); @@ -3003,6 +3166,11 @@ function TTCPBlockSocket.SSLGetPeerSubjectHash: Cardinal; var cert: PX509; begin + if not assigned(FSsl) then + begin + Result := 0; + Exit; + end; cert := SSLGetPeerCertificate(Fssl); Result := SslX509NameHash(SslX509GetSubjectName(cert)); SslX509Free(cert); @@ -3012,6 +3180,11 @@ function TTCPBlockSocket.SSLGetPeerIssuerHash: Cardinal; var cert: PX509; begin + if not assigned(FSsl) then + begin + Result := 0; + Exit; + end; cert := SSLGetPeerCertificate(Fssl); Result := SslX509NameHash(SslX509GetIssuerName(cert)); SslX509Free(cert); @@ -3022,6 +3195,11 @@ var cert: PX509; x: integer; begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; cert := SSLGetPeerCertificate(Fssl); setlength(Result, EVP_MAX_MD_SIZE); SslX509Digest(cert, SslEvpMd5, PChar(Result), @x); @@ -3029,6 +3207,65 @@ begin SslX509Free(cert); end; +function TTCPBlockSocket.SSLGetCertInfo: string; +var + cert: PX509; + x, y: integer; + b: PBIO; + s: string; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + b := BioNew(BioSMem); + try + X509Print(b, cert); + x := bioctrlpending(b); + setlength(s,x); + y := bioread(b,PChar(s),x); + if y > 0 then + setlength(s, y); + Result := ReplaceString(s, LF, CRLF); + finally + BioFreeAll(b); + end; +end; + +function TTCPBlockSocket.SSLGetCipherName: string; +begin + if not assigned(FSsl) then + Result := '' + else + Result := SslCipherGetName(SslGetCurrentCipher(FSsl)); +end; + +function TTCPBlockSocket.SSLGetCipherBits: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), nil); +end; + +function TTCPBlockSocket.SSLGetCipherAlgBits: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + SSLCipherGetBits(SslGetCurrentCipher(FSsl), @Result); +end; + +function TTCPBlockSocket.SSLGetVerifyCert: integer; +begin + if not assigned(FSsl) then + Result := 1 + else + Result := SslGetVerifyResult(FSsl); +end; + function TTCPBlockSocket.GetSocketType: integer; begin Result := SOCK_STREAM; @@ -3091,12 +3328,14 @@ begin end; synsock.WSAStartup(WinsockLevel, WsaDataOnce); end; +{$ENDIF} finalization begin +{$IFDEF ONCEWINSOCK} synsock.WSACleanup; DestroySocketInterface; -end; {$ENDIF} +end; end. diff --git a/dnssend.pas b/dnssend.pas index 79d1a95..afad187 100644 --- a/dnssend.pas +++ b/dnssend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.002.002 | +| Project : Ararat Synapse | 002.003.004 | |==============================================================================| | Content: DNS client | |==============================================================================| @@ -44,15 +44,19 @@ // RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$H+} -unit DNSsend; +unit dnssend; interface uses SysUtils, Classes, - blcksock, SynaUtil, synsock; + blcksock, synautil, synsock; const cDnsProtocol = 'domain'; @@ -89,7 +93,7 @@ const QTYPE_LOC = 29; // RFC-1876 QTYPE_NXT = 30; // RFC-2065 - QTYPE_SRV = 33; // RFC-2052 + QTYPE_SRV = 33; QTYPE_NAPTR = 35; // RFC-2168 QTYPE_KX = 36; @@ -294,7 +298,7 @@ function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; QType: Integer): string; var Rname: string; - RType, Len, j, x, n: Integer; + RType, Len, j, x, y, z, n: Integer; R: string; t1, t2, ttl: integer; ip6: TSockAddrIn6; @@ -313,7 +317,7 @@ begin Inc(i, 2); // i point to begin of data j := i; i := i + len; // i point to next record - if Length(FBuffer) >= i then + if Length(FBuffer) >= (i - 1) then case RType of QTYPE_A: begin @@ -401,6 +405,20 @@ begin R := R + ',' + DecodeLabels(j); R := R + ',' + DecodeLabels(j); end; + QTYPE_SRV: + // Author: Dan + begin + x := DecodeInt(FBuffer, j); + Inc(j, 2); + y := DecodeInt(FBuffer, j); + Inc(j, 2); + z := DecodeInt(FBuffer, j); + Inc(j, 2); + R := IntToStr(x); // Priority + R := R + ',' + IntToStr(y); // Weight + R := R + ',' + IntToStr(z); // Port + R := R + ',' + DecodeLabels(j); // Server DNS Name + end; end; if R <> '' then Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R); @@ -433,6 +451,7 @@ begin FAuthoritative := False; if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then begin + Result := True; flag := DecodeInt(Buf, 3); FRCode := Flag and $000F; FAuthoritative := (Flag and $0400) > 0; @@ -463,7 +482,6 @@ begin if (arcount > 0) and (Length(Buf) > i) then // decode additional info for n := 1 to arcount do DecodeResource(i, FAdditionalInfo, QType); - Result := True; end; end; end; diff --git a/ftpsend.pas b/ftpsend.pas index c95ad37..65d9af6 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.006.006 | +| Project : Ararat Synapse | 002.007.000 | |==============================================================================| | Content: FTP client | |==============================================================================| @@ -43,13 +43,23 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -unit FTPsend; +// RFC-959, RFC-2228, RFC-2428 + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ftpsend; interface uses SysUtils, Classes, - blcksock, SynaUtil, SynaCode; + {$IFDEF STREAMSEC} + TlsInternalServer, TlsSynaSock, + {$ENDIF} + blcksock, synautil, synacode; const cFtpProtocol = 'ftp'; @@ -88,8 +98,14 @@ type TFTPSend = class(TSynaClient) private FOnStatus: TFTPStatus; + {$IFDEF STREAMSEC} + FSock: TSsTCPBlockSocket; + FDSock: TSsTCPBlockSocket; + FTLSServer: TCustomTLSInternalServer; + {$ELSE} FSock: TTCPBlockSocket; FDSock: TTCPBlockSocket; + {$ENDIF} FResultCode: Integer; FResultString: string; FFullResult: TStringList; @@ -113,6 +129,8 @@ type FBinaryMode: Boolean; FAutoTLS: Boolean; FIsTLS: Boolean; + FIsDataTLS: Boolean; + FTLSonData: Boolean; FFullSSL: Boolean; function Auth(Mode: integer): Boolean; function Connect: Boolean; @@ -160,8 +178,14 @@ type property FWUsername: string read FFWUsername Write FFWUsername; property FWPassword: string read FFWPassword Write FFWPassword; 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} property Sock: TTCPBlockSocket read FSock; property DSock: TTCPBlockSocket read FDSock; +{$ENDIF} property DataStream: TMemoryStream read FDataStream; property DataIP: string read FDataIP; property DataPort: string read FDataPort; @@ -176,6 +200,8 @@ type property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; property FullSSL: Boolean read FFullSSL Write FFullSSL; property IsTLS: Boolean read FIsTLS; + property IsDataTLS: Boolean read FIsDataTLS; + property TLSonData: Boolean read FTLSonData write FTLSonData; end; function FtpGetFile(const IP, Port, FileName, LocalFile, @@ -193,9 +219,18 @@ 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; @@ -214,6 +249,8 @@ begin FAutoTLS := False; FFullSSL := False; FIsTLS := False; + FIsDataTLS := False; + FTLSonData := True; end; destructor TFTPSend.Destroy; @@ -447,8 +484,23 @@ 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) @@ -464,19 +516,37 @@ begin if not Connect then Exit; FIsTLS := FFullSSL; + FIsDataTLS := False; if (ReadResult div 100) <> 2 then Exit; 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 + Result := False; +{$ELSE} FSock.SSLDoConnect; - FIsTLS := True; + FIsTLS := FSock.LastError = 0; + FDSock.SSLCertificateFile := FSock.SSLCertificateFile; + FDSock.SSLPrivateKeyFile := FSock.SSLPrivateKeyFile; + FDSock.SSLCertCAFile := FSock.SSLCertCAFile; +{$ENDIF} end; if not Auth(FFWMode) then Exit; if FIsTLS then begin - FTPCommand('PROT P'); + if FTLSonData then + FIsDataTLS := (FTPCommand('PROT P') div 100) = 2; + if not FIsDataTLS then + FTPCommand('PROT C'); FTPCommand('PBSZ 0'); end; FTPCommand('TYPE I'); @@ -627,8 +697,22 @@ begin Result := True; end; end; - if FIsTLS then + 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.SSLDoConnect; + Result := FDSock.LastError = 0; +{$ENDIF} + end; end; function TFTPSend.DataRead(const DestStream: TStream): Boolean; @@ -908,7 +992,7 @@ end; procedure TFTPSend.Abort; begin - FDSock.CloseSocket; + FDSock.AbortSocket; end; {==============================================================================} @@ -1072,6 +1156,10 @@ begin else Exit; if (year = 0) or (month = 0) or (mday = 0) then Exit; + // for date 2-29 find last leap year. (fix for non-existent year) + if (month = 2) and (mday = 29) then + while not IsLeapYear(year) do + Dec(year); flr.FileTime := t + Encodedate(year, month, mday); end; 3 : begin diff --git a/ftptsend.pas b/ftptsend.pas new file mode 100644 index 0000000..86597cd --- /dev/null +++ b/ftptsend.pas @@ -0,0 +1,352 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.002 | +|==============================================================================| +| Content: Trivial FTP (TFTP) client and server | +|==============================================================================| +| Copyright (c)1999-2003, 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)2003. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +// RFC-1350 + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +unit ftptsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cTFTPProtocol = '69'; + +type + TTFTPSend = class(TSynaClient) + private + FSock: TUDPBlockSocket; + FErrorCode: integer; + FErrorString: string; + FData: TMemoryStream; + FRequestIP: string; + FRequestPort: string; + function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; + function RecvPacket(Serial: word; var Value: string): Boolean; + public + constructor Create; + destructor Destroy; override; + function SendFile(const Filename: string): Boolean; + function RecvFile(const Filename: string): Boolean; + function WaitForRequest(var Req: word; var filename: string): Boolean; + procedure ReplyError(Error: word; Description: string); + function ReplyRecv: Boolean; + function ReplySend: Boolean; + published + property ErrorCode: integer read FErrorCode; + property ErrorString: string read FErrorString; + property Data: TMemoryStream read FData; + property RequestIP: string read FRequestIP write FRequestIP; + property RequestPort: string read FRequestPort write FRequestPort; + end; + +implementation + +constructor TTFTPSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FTargetPort := cTFTPProtocol; + FData := TMemoryStream.Create; + FErrorCode := 0; + FErrorString := ''; +end; + +destructor TTFTPSend.Destroy; +begin + FSock.Free; + FData.Free; + inherited Destroy; +end; + +function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; +var + s, sh: string; +begin + FErrorCode := 0; + FErrorString := ''; + Result := false; + if Cmd <> 2 then + s := CodeInt(Cmd) + CodeInt(Serial) + Value + else + s := CodeInt(Cmd) + Value; + FSock.SendString(s); + s := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + if length(s) >= 4 then + begin + sh := CodeInt(4) + CodeInt(Serial); + if Pos(sh, s) = 1 then + Result := True + else + if s[1] = #5 then + begin + FErrorCode := DecodeInt(s, 3); + Delete(s, 1, 4); + FErrorString := SeparateLeft(s, #0); + end; + end; +end; + +function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean; +var + s: string; + ser: word; +begin + FErrorCode := 0; + FErrorString := ''; + Result := False; + Value := ''; + s := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + if length(s) >= 4 then + if DecodeInt(s, 1) = 3 then + begin + ser := DecodeInt(s, 3); + if ser = Serial then + begin + Delete(s, 1, 4); + Value := s; + S := CodeInt(4) + CodeInt(ser); + FSock.SendString(s); + Result := FSock.LastError = 0; + end + else + begin + S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0; + FSock.SendString(s); + end; + end; + if DecodeInt(s, 1) = 5 then + begin + FErrorCode := DecodeInt(s, 3); + Delete(s, 1, 4); + FErrorString := SeparateLeft(s, #0); + end; +end; + +function TTFTPSend.SendFile(const Filename: string): Boolean; +var + s: string; + ser: word; + n, n1, n2: integer; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + FSock.Connect(FTargetHost, FTargetPort); + try + if FSock.LastError = 0 then + begin + s := Filename + #0 + 'octet' + #0; + if not Sendpacket(2, 0, s) then + Exit; + ser := 1; + FData.Position := 0; + n1 := FData.Size div 512; + n2 := FData.Size mod 512; + for n := 1 to n1 do + begin + SetLength(s, 512); + FData.Read(pointer(s)^, 512); + if not Sendpacket(3, ser, s) then + Exit; + inc(ser); + end; + SetLength(s, n2); + FData.Read(pointer(s)^, n2); + if not Sendpacket(3, ser, s) then + Exit; + Result := True; + end; + finally + FSock.CloseSocket; + end; +end; + +function TTFTPSend.RecvFile(const Filename: string): Boolean; +var + s: string; + ser: word; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + FSock.Connect(FTargetHost, FTargetPort); + try + if FSock.LastError = 0 then + begin + s := CodeInt(1) + Filename + #0 + 'octet' + #0; + FSock.SendString(s); + if FSock.LastError <> 0 then + Exit; + FData.Clear; + ser := 1; + repeat + if not RecvPacket(ser, s) then + Exit; + inc(ser); + FData.Write(pointer(s)^, length(s)); + until length(s) <> 512; + FData.Position := 0; + Result := true; + end; + finally + FSock.CloseSocket; + end; +end; + +function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean; +var + s: string; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + FSock.Bind('0.0.0.0', FTargetPort); + if FSock.LastError = 0 then + begin + s := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + if Length(s) >= 4 then + begin + FRequestIP := FSock.GetRemoteSinIP; + FRequestPort := IntToStr(FSock.GetRemoteSinPort); + Req := DecodeInt(s, 1); + delete(s, 1, 2); + filename := SeparateLeft(s, #0); + s := SeparateRight(s, #0); + s := SeparateLeft(s, #0); + Result := lowercase(s) = 'octet'; + end; + end; +end; + +procedure TTFTPSend.ReplyError(Error: word; Description: string); +var + s: string; +begin + FSock.CloseSocket; + FSock.Connect(FRequestIP, FRequestPort); + s := CodeInt(5) + CodeInt(Error) + Description + #0; + FSock.SendString(s); + FSock.CloseSocket; +end; + +function TTFTPSend.ReplyRecv: Boolean; +var + s: string; + ser: integer; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + FSock.Connect(FRequestIP, FRequestPort); + try + s := CodeInt(4) + CodeInt(0); + FSock.SendString(s); + FData.Clear; + ser := 1; + repeat + if not RecvPacket(ser, s) then + Exit; + inc(ser); + FData.Write(pointer(s)^, length(s)); + until length(s) <> 512; + FData.Position := 0; + Result := true; + finally + FSock.CloseSocket; + end; +end; + +function TTFTPSend.ReplySend: Boolean; +var + s: string; + ser: word; + n, n1, n2: integer; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + FSock.Connect(FRequestIP, FRequestPort); + try + ser := 1; + FData.Position := 0; + n1 := FData.Size div 512; + n2 := FData.Size mod 512; + for n := 1 to n1 do + begin + SetLength(s, 512); + FData.Read(pointer(s)^, 512); + if not Sendpacket(3, ser, s) then + Exit; + inc(ser); + end; + SetLength(s, n2); + FData.Read(pointer(s)^, n2); + if not Sendpacket(3, ser, s) then + Exit; + Result := True; + finally + FSock.CloseSocket; + end; +end; + +{==============================================================================} + +end. diff --git a/httpsend.pas b/httpsend.pas index 0048bd8..d029d1f 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.006.004 | +| Project : Ararat Synapse | 003.006.007 | |==============================================================================| | Content: HTTP client | |==============================================================================| @@ -42,7 +42,14 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -unit HTTPSend; +//RFC-1867, RFC-1947, RFC-2388, RFC-2616 + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit httpsend; interface @@ -51,7 +58,7 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, SynaUtil, SynaCode; + blcksock, synautil, synacode; const cHttpProtocol = '80'; @@ -530,7 +537,7 @@ end; procedure THTTPSend.Abort; begin - FSock.CloseSocket; + FSock.AbortSocket; end; {==============================================================================} diff --git a/imapsend.pas b/imapsend.pas index 9a85bc3..da737f8 100644 --- a/imapsend.pas +++ b/imapsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.005 | +| Project : Ararat Synapse | 002.004.002 | |==============================================================================| | Content: IMAP4rev1 client | |==============================================================================| @@ -42,10 +42,14 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-2060 -//RFC-2595 +//RFC-2060, RFC-2595 -unit IMAPsend; +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit imapsend; interface @@ -54,7 +58,7 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, SynaUtil, SynaCode; + blcksock, synautil, synacode; const cIMAPProtocol = '143'; @@ -121,6 +125,8 @@ 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 AddFlagsMess(MessID: integer; Flags: string): Boolean; + function DelFlagsMess(MessID: integer; Flags: string): Boolean; function StartTLS: Boolean; function GetUID(MessID: integer; var UID : Integer): Boolean; function FindCap(const Value: string): string; @@ -556,7 +562,8 @@ begin ProcessLiterals; for n := 0 to FFullResult.Count - 1 do begin - s := UpperCase(FFullResult[n]); + s := FFullResult[n]; +// s := UpperCase(FFullResult[n]); if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then begin t := SeparateRight(s, Value); @@ -674,6 +681,26 @@ begin Result := IMAPcommand(s) = 'OK'; end; +function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean; var s: string; diff --git a/ldapsend.pas b/ldapsend.pas new file mode 100644 index 0000000..f0c6680 --- /dev/null +++ b/ldapsend.pas @@ -0,0 +1,1095 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.011 | +|==============================================================================| +| Content: LDAP client | +|==============================================================================| +| Copyright (c)1999-2003, 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)2003. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +//RFC-2251, RFC-2254, RFC-2829, RFC-2830 + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ldapsend; + +interface + +uses + Classes, SysUtils, + {$IFDEF STREAMSEC} + TlsInternalServer, TlsSynaSock, + {$ENDIF} + blcksock, synautil, asn1util, synacode; + +const + cLDAPProtocol = '389'; + + LDAP_ASN1_BIND_REQUEST = $60; + LDAP_ASN1_BIND_RESPONSE = $61; + LDAP_ASN1_UNBIND_REQUEST = $42; + LDAP_ASN1_SEARCH_REQUEST = $63; + LDAP_ASN1_SEARCH_ENTRY = $64; + LDAP_ASN1_SEARCH_DONE = $65; + LDAP_ASN1_SEARCH_REFERENCE = $73; + LDAP_ASN1_MODIFY_REQUEST = $66; + LDAP_ASN1_MODIFY_RESPONSE = $67; + LDAP_ASN1_ADD_REQUEST = $68; + LDAP_ASN1_ADD_RESPONSE = $69; + LDAP_ASN1_DEL_REQUEST = $4A; + LDAP_ASN1_DEL_RESPONSE = $6B; + LDAP_ASN1_MODIFYDN_REQUEST = $6C; + LDAP_ASN1_MODIFYDN_RESPONSE = $6D; + LDAP_ASN1_COMPARE_REQUEST = $6E; + LDAP_ASN1_COMPARE_RESPONSE = $6F; + LDAP_ASN1_ABANDON_REQUEST = $70; + LDAP_ASN1_EXT_REQUEST = $77; + LDAP_ASN1_EXT_RESPONSE = $78; + + +type + + TLDAPAttribute = class(TStringList) + private + FAttributeName: string; + FIsBinary: Boolean; + protected + function Get(Index: integer): string; override; + procedure Put(Index: integer; const Value: string); override; + procedure SetAttributeName(Value: string); + published + property AttributeName: string read FAttributeName Write SetAttributeName; + property IsBinary: Boolean read FIsBinary; + end; + + TLDAPAttributeList = class(TObject) + private + FAttributeList: TList; + function GetAttribute(Index: integer): TLDAPAttribute; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + function Count: integer; + function Add: TLDAPAttribute; + property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default; + end; + + TLDAPResult = class(TObject) + private + FObjectName: string; + FAttributes: TLDAPAttributeList; + public + constructor Create; + destructor Destroy; override; + published + property ObjectName: string read FObjectName write FObjectName; + property Attributes: TLDAPAttributeList read FAttributes; + end; + + TLDAPResultList = class(TObject) + private + FResultList: TList; + function GetResult(Index: integer): TLDAPResult; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + function Count: integer; + function Add: TLDAPResult; + property Items[Index: Integer]: TLDAPResult read GetResult; default; + end; + + TLDAPModifyOp = ( + MO_Add, + MO_Delete, + MO_Replace + ); + + TLDAPSearchScope = ( + SS_BaseObject, + SS_SingleLevel, + SS_WholeSubtree + ); + + TLDAPSearchAliases = ( + SA_NeverDeref, + SA_InSearching, + SA_FindingBaseObj, + SA_Always + ); + + TLDAPSend = class(TSynaClient) + private + {$IFDEF STREAMSEC} + FSock: TSsTCPBlockSocket; + FTLSServer: TCustomTLSInternalServer; + {$ELSE} + FSock: TTCPBlockSocket; + {$ENDIF} + FResultCode: Integer; + FResultString: string; + FFullResult: string; + FUsername: string; + FPassword: string; + FAutoTLS: Boolean; + FFullSSL: Boolean; + FSeq: integer; + FResponseCode: integer; + FResponseDN: string; + FReferals: TStringList; + FVersion: integer; + FSearchScope: TLDAPSearchScope; + FSearchAliases: TLDAPSearchAliases; + FSearchSizeLimit: integer; + FSearchTimeLimit: integer; + FSearchResult: TLDAPResultList; + FExtName: string; + FExtValue: string; + function Connect: Boolean; + function BuildPacket(const Value: string): string; + function ReceiveResponse: string; + function DecodeResponse(const Value: string): string; + function LdapSasl(Value: string): string; + function TranslateFilter(Value: string): string; + function GetErrorString(Value: integer): string; + public + constructor Create; + destructor Destroy; override; + function Login: Boolean; + function Bind: Boolean; + function BindSasl: Boolean; + procedure Logout; + function Modify(obj: string; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; + function Add(obj: string; const Value: TLDAPAttributeList): Boolean; + function Delete(obj: string): Boolean; + function ModifyDN(obj, newRDN, newSuperior: string; DeleteoldRDN: Boolean): Boolean; + function Compare(obj, AttributeValue: string): Boolean; + function Search(obj: string; TypesOnly: Boolean; Filter: string; + const Attributes: TStrings): Boolean; + function Extended(const Name, Value: string): Boolean; + + function StartTLS: Boolean; + published + property Version: integer read FVersion Write FVersion; + property ResultCode: Integer read FResultCode; + property ResultString: string read FResultString; + property FullResult: string read FFullResult; + property Username: string read FUsername Write FUsername; + property Password: string read FPassword Write FPassword; + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + property FullSSL: Boolean read FFullSSL Write FFullSSL; + property Seq: integer read FSeq; + property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope; + property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases; + property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit; + property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit; + property SearchResult: TLDAPResultList read FSearchResult; + property Referals: TStringList read FReferals; + property ExtName: string read FExtName; + property ExtValue: string read FExtValue; +{$IFDEF STREAMSEC} + property Sock: TSsTCPBlockSocket read FSock; + property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; +{$ELSE} + property Sock: TTCPBlockSocket read FSock; +{$ENDIF} + end; + +function LDAPResultDump(const Value: TLDAPResultList): string; + +implementation + +{==============================================================================} +function TLDAPAttribute.Get(Index: integer): string; +begin + Result := inherited Get(Index); + if FIsbinary then + Result := DecodeBase64(Result); +end; + +procedure TLDAPAttribute.Put(Index: integer; const Value: string); +var + s: string; +begin + s := Value; + if FIsbinary then + s := EncodeBase64(Value); + inherited Put(Index, s); +end; + +procedure TLDAPAttribute.SetAttributeName(Value: string); +begin + FAttributeName := Value; + FIsBinary := Pos(';binary', Lowercase(value)) > 0; +end; + +{==============================================================================} +constructor TLDAPAttributeList.Create; +begin + inherited Create; + FAttributeList := TList.Create; +end; + +destructor TLDAPAttributeList.Destroy; +begin + Clear; + FAttributeList.Free; + inherited Destroy; +end; + +procedure TLDAPAttributeList.Clear; +var + n: integer; + x: TLDAPAttribute; +begin + for n := Count - 1 downto 0 do + begin + x := GetAttribute(n); + if Assigned(x) then + x.Free; + end; + FAttributeList.Clear; +end; + +function TLDAPAttributeList.Count: integer; +begin + Result := FAttributeList.Count; +end; + +function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute; +begin + Result := nil; + if Index < Count then + Result := TLDAPAttribute(FAttributeList[Index]); +end; + +function TLDAPAttributeList.Add: TLDAPAttribute; +begin + Result := TLDAPAttribute.Create; + FAttributeList.Add(Result); +end; + +{==============================================================================} +constructor TLDAPResult.Create; +begin + inherited Create; + FAttributes := TLDAPAttributeList.Create; +end; + +destructor TLDAPResult.Destroy; +begin + FAttributes.Free; + inherited Destroy; +end; + +{==============================================================================} +constructor TLDAPResultList.Create; +begin + inherited Create; + FResultList := TList.Create; +end; + +destructor TLDAPResultList.Destroy; +begin + Clear; + FResultList.Free; + inherited Destroy; +end; + +procedure TLDAPResultList.Clear; +var + n: integer; + x: TLDAPResult; +begin + for n := Count - 1 downto 0 do + begin + x := GetResult(n); + if Assigned(x) then + x.Free; + end; + FResultList.Clear; +end; + +function TLDAPResultList.Count: integer; +begin + Result := FResultList.Count; +end; + +function TLDAPResultList.GetResult(Index: integer): TLDAPResult; +begin + Result := nil; + if Index < Count then + Result := TLDAPResult(FResultList[Index]); +end; + +function TLDAPResultList.Add: TLDAPResult; +begin + Result := TLDAPResult.Create; + FResultList.Add(Result); +end; + +{==============================================================================} +constructor TLDAPSend.Create; +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; + FUsername := ''; + FPassword := ''; + FAutoTLS := False; + FFullSSL := False; + FSeq := 0; + FVersion := 3; + FSearchScope := SS_WholeSubtree; + FSearchAliases := SA_Always; + FSearchSizeLimit := 0; + FSearchTimeLimit := 0; + FSearchResult := TLDAPResultList.Create; +end; + +destructor TLDAPSend.Destroy; +begin + FSock.Free; + FSearchResult.Free; + FReferals.Free; + inherited Destroy; +end; + +function TLDAPSend.GetErrorString(Value: integer): string; +begin + case Value of + 0: + Result := 'Success'; + 1: + Result := 'Operations error'; + 2: + Result := 'Protocol error'; + 3: + Result := 'Time limit Exceeded'; + 4: + Result := 'Size limit Exceeded'; + 5: + Result := 'Compare FALSE'; + 6: + Result := 'Compare TRUE'; + 7: + Result := 'Auth method not supported'; + 8: + Result := 'Strong auth required'; + 9: + Result := '-- reserved --'; + 10: + Result := 'Referal'; + 11: + Result := 'Admin limit exceeded'; + 12: + Result := 'Unavailable critical extension'; + 13: + Result := 'Confidentality required'; + 14: + Result := 'Sasl bind in progress'; + 16: + Result := 'No such attribute'; + 17: + Result := 'Undefined attribute type'; + 18: + Result := 'Inappropriate matching'; + 19: + Result := 'Constraint violation'; + 20: + Result := 'Attribute or value exists'; + 21: + Result := 'Invalid attribute syntax'; + 32: + Result := 'No such object'; + 33: + Result := 'Alias problem'; + 34: + Result := 'Invalid DN syntax'; + 36: + Result := 'Alias dereferencing problem'; + 48: + Result := 'Inappropriate authentication'; + 49: + Result := 'Invalid credentials'; + 50: + Result := 'Insufficient access rights'; + 51: + Result := 'Busy'; + 52: + Result := 'Unavailable'; + 53: + Result := 'Unwilling to perform'; + 54: + Result := 'Loop detect'; + 64: + Result := 'Naming violation'; + 65: + Result := 'Object class violation'; + 66: + Result := 'Not allowed on non leaf'; + 67: + Result := 'Not allowed on RDN'; + 68: + Result := 'Entry already exists'; + 69: + Result := 'Object class mods prohibited'; + 71: + Result := 'Affects multiple DSAs'; + 80: + Result := 'Other'; + else + Result := '--unknown--'; + end; +end; + +function TLDAPSend.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FSock.CloseSocket; + 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); + Result := FSock.LastError = 0; +end; + +function TLDAPSend.BuildPacket(const Value: string): string; +begin + Inc(FSeq); + Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value, ASN1_SEQ); +end; + +function TLDAPSend.ReceiveResponse: string; +var + x: Byte; + i,j: integer; +begin + Result := ''; + FFullResult := ''; + x := FSock.RecvByte(FTimeout); + if x <> ASN1_SEQ then + Exit; + Result := Char(x); + x := FSock.RecvByte(FTimeout); + Result := Result + Char(x); + if x < $80 then + i := 0 + else + i := x and $7F; + if i > 0 then + Result := Result + FSock.RecvBufferStr(i, Ftimeout); + if FSock.LastError <> 0 then + begin + Result := ''; + Exit; + end; + //get length of LDAP packet + j := 2; + i := ASNDecLen(j, Result); + //retreive rest of LDAP packet + if i > 0 then + Result := Result + FSock.RecvBufferStr(i, Ftimeout); + if FSock.LastError <> 0 then + begin + Result := ''; + Exit; + end; + FFullResult := Result; +end; + +function TLDAPSend.DecodeResponse(const Value: string): string; +var + i, x: integer; + Svt: Integer; + s, t: string; +begin + Result := ''; + FResultCode := -1; + FResultstring := ''; + FResponseCode := -1; + FResponseDN := ''; + FReferals.Clear; + i := 1; + ASNItem(i, Value, Svt); + x := StrToIntDef(ASNItem(i, Value, Svt), 0); + if (svt <> ASN1_INT) or (x <> FSeq) then + Exit; + s := ASNItem(i, Value, Svt); + FResponseCode := svt; + if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE, + LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE, + LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE, + LDAP_ASN1_EXT_RESPONSE] then + begin + FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1); + FResponseDN := ASNItem(i, Value, Svt); + FResultString := ASNItem(i, Value, Svt); + if FResultString = '' then + FResultString := GetErrorString(FResultCode); + if FResultCode = 10 then + begin + s := ASNItem(i, Value, Svt); + if svt = $A3 then + begin + x := 1; + while x < Length(s) do + begin + t := ASNItem(x, s, Svt); + FReferals.Add(t); + end; + end; + end; + end; + Result := Copy(Value, i, Length(Value) - i + 1); +end; + +function TLDAPSend.LdapSasl(Value: string): string; +var + nonce, cnonce, nc, realm, qop, uri, response: string; + s: string; + a1, a2: string; + l: TStringList; + n: integer; +begin + l := TStringList.Create; + try + nonce := ''; + realm := ''; + l.CommaText := Value; + n := IndexByBegin('nonce=', l); + if n >= 0 then + nonce := UnQuoteStr(SeparateRight(l[n], 'nonce='), '"'); + n := IndexByBegin('realm=', l); + if n >= 0 then + realm := UnQuoteStr(SeparateRight(l[n], 'realm='), '"'); + cnonce := IntToHex(GetTick, 8); + nc := '00000001'; + qop := 'auth'; + uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP); + a1 := md5(FUsername + ':' + realm + ':' + FPassword) + + ':' + nonce + ':' + cnonce; + a2 := 'AUTHENTICATE:' + uri; + s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':' + + qop +':'+strtohex(md5(a2)); + response := strtohex(md5(s)); + + Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="'; + Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop='; + Result := Result + qop + ',digest-uri="' + uri + '",response=' + response; + finally + l.Free; + end; +end; + +function TLDAPSend.TranslateFilter(Value: string): string; +var + x: integer; + s, t, l, r: string; + c: char; + attr, rule: string; + dn: Boolean; +begin + Result := ''; + if Value = '' then + Exit; + s := Value; + if Value[1] = '(' then + begin + x := RPos(')', Value); + s := Copy(Value, 2, x - 2); + end; + if s = '' then + Exit; + case s[1] of + '!': + // NOT rule (recursive call) + begin + Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $82); + end; + '&': + // AND rule (recursive call) + begin + repeat + t := GetBetween('(', ')', s); + s := SeparateRight(s, t); + if s <> '' then + if s[1] = ')' then + System.Delete(s, 1, 1); + Result := Result + TranslateFilter(t); + until s = ''; + Result := ASNOBject(Result, $A0); + end; + '|': + // OR rule (recursive call) + begin + repeat + t := GetBetween('(', ')', s); + s := SeparateRight(s, t); + if s <> '' then + if s[1] = ')' then + System.Delete(s, 1, 1); + Result := Result + TranslateFilter(t); + until s = ''; + Result := ASNOBject(Result, $A1); + end; + else + begin + l := SeparateLeft(s, '='); + r := SeparateRight(s, '='); + if l <> '' then + begin + c := l[Length(l)]; + case c of + ':': + // Extensible match + begin + System.Delete(l, Length(l), 1); + dn := False; + attr := ''; + rule := ''; + if Pos(':dn', l) > 0 then + begin + dn := True; + l := ReplaceString(l, ':dn', ''); + end; + attr := SeparateLeft(l, ':'); + rule := SeparateRight(l, ':'); + if rule = l then + rule := ''; + if rule <> '' then + Result := ASNObject(rule, $81); + if attr <> '' then + Result := Result + ASNObject(attr, $82); + Result := Result + ASNObject(DecodeTriplet(r, '\'), $83); + if dn then + Result := Result + ASNObject(AsnEncInt($ff), $84) + else + Result := Result + ASNObject(AsnEncInt(0), $84); + Result := ASNOBject(Result, $a9); + end; + '~': + // Approx match + begin + System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a8); + end; + '>': + // Greater or equal match + begin + System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a5); + end; + '<': + // Less or equal match + begin + System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a6); + end; + else + // present + if r = '*' then + Result := ASNOBject(l, $87) + else + if Pos('*', r) > 0 then + // substrings + begin + s := Fetch(r, '*'); + if s <> '' then + Result := ASNOBject(DecodeTriplet(s, '\'), $80); + while r <> '' do + begin + if Pos('*', r) <= 0 then + break; + s := Fetch(r, '*'); + Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81); + end; + if r <> '' then + Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(Result, ASN1_SEQ); + Result := ASNOBject(Result, $a4); + end + else + begin + // Equality match + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a3); + end; + end; + end; + end; + end; +end; + +function TLDAPSend.Login: Boolean; +begin + Result := False; + if not Connect then + Exit; + Result := True; + if FAutoTLS then + StartTLS; +end; + +function TLDAPSend.Bind: Boolean; +var + s: string; +begin + s := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject(FUsername, ASN1_OCTSTR) + + ASNObject(FPassword, $80); + s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.BindSasl: Boolean; +var + s, t: string; + x, xt: integer; + digreq: string; +begin + Result := False; + if FPassword = '' then + Result := Bind + else + begin + digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject('', ASN1_NULL) + + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3); + digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(digreq)); + s := ReceiveResponse; + t := DecodeResponse(s); + if FResultCode = 14 then + begin + s := t; + x := 1; + t := ASNItem(x, s, xt); + s := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject('', ASN1_NULL) + + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3) + + ASNObject(LdapSasl(t), ASN1_OCTSTR); + s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + if FResultCode = 14 then + begin + Fsock.SendString(BuildPacket(digreq)); + s := ReceiveResponse; + DecodeResponse(s); + end; + Result := FResultCode = 0; + end; + end; +end; + +procedure TLDAPSend.Logout; +begin + Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST))); + FSock.CloseSocket; +end; + +function TLDAPSend.Modify(obj: string; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; +var + s: string; + n: integer; +begin + s := ''; + for n := 0 to Value.Count -1 do + s := s + ASNObject(Value[n], ASN1_OCTSTR); + s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF); + s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, ASN1_SEQ); + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Add(obj: string; const Value: TLDAPAttributeList): Boolean; +var + s, t: string; + n, m: integer; +begin + s := ''; + for n := 0 to Value.Count - 1 do + begin + t := ''; + for m := 0 to Value[n].Count - 1 do + t := t + ASNObject(Value[n][m], ASN1_OCTSTR); + t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR) + + ASNObject(t, ASN1_SETOF); + s := s + ASNObject(t, ASN1_SEQ); + end; + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_ADD_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Delete(obj: string): Boolean; +var + s: string; +begin + s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: string; DeleteOldRDN: Boolean): Boolean; +var + s: string; +begin + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR); + if DeleteOldRDN then + s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) + else + s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); + if newSuperior <> '' then + s := s + ASNObject(newSuperior, $80); + s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Compare(obj, AttributeValue: string): Boolean; +var + s: string; +begin + s := ASNObject(SeparateLeft(AttributeValue, '='), ASN1_OCTSTR) + + ASNObject(SeparateRight(AttributeValue, '='), ASN1_OCTSTR); + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Search(obj: string; TypesOnly: Boolean; Filter: string; + const Attributes: TStrings): Boolean; +var + s, t, u: string; + n, i, x: integer; + r: TLDAPResult; + a: TLDAPAttribute; +begin + FSearchResult.Clear; + FReferals.Clear; + s := ASNObject(obj, ASN1_OCTSTR); + s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM); + s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM); + s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT); + s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT); + if TypesOnly then + s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) + else + s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); + if Filter = '' then + Filter := '(objectclass=*)'; + t := TranslateFilter(Filter); + if t = '' then + s := s + ASNObject('', ASN1_NULL) + else + s := s + t; + t := ''; + for n := 0 to Attributes.Count - 1 do + t := t + ASNObject(Attributes[n], ASN1_OCTSTR); + s := s + ASNObject(t, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST); + Fsock.SendString(BuildPacket(s)); + repeat + s := ReceiveResponse; + t := DecodeResponse(s); + if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then + begin + //dekoduj zaznam + r := FSearchResult.Add; + n := 1; + r.ObjectName := ASNItem(n, t, x); + ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + while n < Length(t) do + begin + s := ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + i := n + Length(s); + a := r.Attributes.Add; + u := ASNItem(n, t, x); + a.AttributeName := u; + ASNItem(n, t, x); + if x = ASN1_SETOF then + while n < i do + begin + u := ASNItem(n, t, x); + a.Add(UnquoteStr(u, '"')); + end; + end; + end; + end; + end; + if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then + begin + n := 1; + while n < Length(t) do + FReferals.Add(ASNItem(n, t, x)); + end; + until FResponseCode = LDAP_ASN1_SEARCH_DONE; + Result := FResultCode = 0; +end; + +function TLDAPSend.Extended(const Name, Value: string): Boolean; +var + s, t: string; + x, xt: integer; +begin + s := ASNObject(Name, $80); + if Value <> '' then + s := s + ASNObject(Value, $81); + s := ASNObject(s, LDAP_ASN1_EXT_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + t := DecodeResponse(s); + Result := FResultCode = 0; + if Result then + begin + x := 1; + FExtName := ASNItem(x, t, xt); + FExtValue := ASNItem(x, t, xt); + end; +end; + + +function TLDAPSend.StartTLS: Boolean; +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; + +{==============================================================================} +function LDAPResultDump(const Value: TLDAPResultList): string; +var + n, m, o: integer; + r: TLDAPResult; + a: TLDAPAttribute; +begin + Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF; + for n := 0 to Value.Count - 1 do + begin + Result := Result + 'Result: ' + IntToStr(n) + CRLF; + r := Value[n]; + Result := Result + ' Object: ' + r.ObjectName + CRLF; + for m := 0 to r.Attributes.Count - 1 do + begin + a := r.Attributes[m]; + Result := Result + ' Attribute: ' + a.AttributeName + CRLF; + for o := 0 to a.Count - 1 do + Result := Result + ' ' + a[o] + CRLF; + end; + end; +end; + +end. diff --git a/mimeinln.pas b/mimeinln.pas index 6291d21..4f741dc 100644 --- a/mimeinln.pas +++ b/mimeinln.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.000.007 | +| Project : Ararat Synapse | 001.001.002 | |==============================================================================| | Content: Inline MIME support procedures and functions | |==============================================================================| @@ -42,18 +42,27 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -unit MIMEinLn; +//RFC-1522 + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit mimeinln; interface uses SysUtils, Classes, - SynaChar, SynaCode, SynaUtil; + synachar, synacode, synautil; function InlineDecode(const Value: string; CP: TMimeChar): string; function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; function NeedInline(const Value: string): boolean; +function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; function InlineCode(const Value: string): string; +function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; function InlineEmail(const Value: string): string; implementation @@ -166,16 +175,16 @@ end; {==============================================================================} -function InlineCode(const Value: string): string; +function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; var c: TMimeChar; begin if NeedInline(Value) then begin - c := IdealCharsetCoding(Value, GetCurCP, + c := IdealCharsetCoding(Value, FromCP, [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]); - Result := InlineEncode(Value, GetCurCP, c); + Result := InlineEncode(Value, FromCP, c); end else Result := Value; @@ -183,7 +192,14 @@ end; {==============================================================================} -function InlineEmail(const Value: string): string; +function InlineCode(const Value: string): string; +begin + Result := InlineCodeEx(Value, GetCurCP); +end; + +{==============================================================================} + +function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; var sd, se: string; begin @@ -192,7 +208,14 @@ begin if sd = '' then Result := se else - Result := '"' + InlineCode(sd) + '"<' + se + '>'; + Result := '"' + InlineCodeEx(sd, FromCP) + '"<' + se + '>'; +end; + +{==============================================================================} + +function InlineEmail(const Value: string): string; +begin + Result := InlineEmailEx(Value, GetCurCP); end; end. diff --git a/mimemess.pas b/mimemess.pas index 978fd04..555f346 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.003 | +| Project : Ararat Synapse | 002.002.003 | |==============================================================================| | Content: MIME message object | |==============================================================================| @@ -42,13 +42,18 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -unit MIMEmess; +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit mimemess; interface uses Classes, SysUtils, - MIMEpart, SynaChar, SynaUtil, MIMEinLn; + mimepart, synachar, synautil, mimeinln; type TMessHeader = class(TObject) @@ -61,6 +66,7 @@ type FCustomHeaders: TStringList; FDate: TDateTime; FXMailer: string; + FCharsetCode: TMimeChar; public constructor Create; destructor Destroy; override; @@ -78,6 +84,7 @@ type property CustomHeaders: TStringList read FCustomHeaders; property Date: TDateTime read FDate Write FDate; property XMailer: string read FXMailer Write FXMailer; + property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; end; TMimeMess = class(TObject) @@ -117,6 +124,7 @@ begin FToList := TStringList.Create; FCCList := TStringList.Create; FCustomHeaders := TStringList.Create; + FCharsetCode := GetCurCP; end; destructor TMessHeader.Destroy; @@ -157,27 +165,27 @@ begin Value.Insert(0, 'X-mailer: ' + FXMailer); Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); if FOrganization <> '' then - Value.Insert(0, 'Organization: ' + InlineCode(FOrganization)); + Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode)); s := ''; for n := 0 to FCCList.Count - 1 do if s = '' then - s := InlineEmail(FCCList[n]) + s := InlineEmailEx(FCCList[n], FCharsetCode) else - s := s + ' , ' + InlineEmail(FCCList[n]); + s := s + ' , ' + InlineEmailEx(FCCList[n], FCharsetCode); if s <> '' then Value.Insert(0, 'CC: ' + s); Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); if FSubject <> '' then - Value.Insert(0, 'Subject: ' + InlineCode(FSubject)); + Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode)); s := ''; for n := 0 to FToList.Count - 1 do if s = '' then - s := InlineEmail(FToList[n]) + s := InlineEmailEx(FToList[n], FCharsetCode) else - s := s + ' , ' + InlineEmail(FToList[n]); + s := s + ' , ' + InlineEmailEx(FToList[n], FCharsetCode); if s <> '' then Value.Insert(0, 'To: ' + s); - Value.Insert(0, 'From: ' + InlineEmail(FFrom)); + Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode)); end; procedure TMessHeader.DecodeHeaders(const Value: TStrings); @@ -186,7 +194,7 @@ var x: Integer; cp: TMimeChar; begin - cp := GetCurCP; + cp := FCharsetCode; Clear; x := 0; while Value.Count > x do @@ -218,7 +226,7 @@ begin begin s := SeparateRight(s, ':'); repeat - t := InlineDecode(fetch(s, ','), cp); + t := InlineDecode(FetchEx(s, ',', '"'), cp); if t <> '' then FToList.Add(t); until s = ''; @@ -228,7 +236,7 @@ begin begin s := SeparateRight(s, ':'); repeat - t := InlineDecode(fetch(s, ','), cp); + t := InlineDecode(FetchEx(s, ',', '"'), cp); if t <> '' then FCCList.Add(t); until s = ''; diff --git a/mimepart.pas b/mimepart.pas index 8d51ec5..5e4c3ac 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.004 | +| Project : Ararat Synapse | 002.004.008 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| @@ -42,16 +42,25 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -unit MIMEpart; +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit mimepart; interface uses SysUtils, Classes, -{$IFNDEF LINUX} +{$IFDEF LINUX} + {$IFDEF FPC} + synafpc, + {$ENDIF} +{$ELSE} Windows, {$ENDIF} - SynaChar, SynaCode, SynaUtil, MIMEinLn; + synachar, synacode, synautil, mimeinln; type @@ -89,9 +98,13 @@ type FSubParts: TList; FOnWalkPart: THookWalkPart; FMaxLineLength: integer; + FSubLevel: integer; + FMaxSubLevel: integer; + FAttachInside: boolean; procedure SetPrimary(Value: string); procedure SetEncoding(Value: string); procedure SetCharset(Value: string); + function IsUUcode(Value: string): boolean; public constructor Create; destructor Destroy; override; @@ -111,6 +124,7 @@ type procedure DecomposeParts; procedure ComposeParts; procedure WalkPart; + function CanSubPart: boolean; published property Primary: string read FPrimary write SetPrimary; property Encoding: string read FEncoding write SetEncoding; @@ -132,6 +146,9 @@ type property PrePart: TStringList read FPrePart; property PostPart: TStringList read FPostPart; property DecodedLines: TMemoryStream read FDecodedLines; + property SubLevel: integer read FSubLevel write FSubLevel; + property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel; + property AttachInside: boolean read FAttachInside; property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart; property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength; end; @@ -216,6 +233,9 @@ begin FTargetCharset := GetCurCP; FDefaultCharset := 'US-ASCII'; FMaxLineLength := 78; + FSubLevel := 0; + FMaxSubLevel := -1; + FAttachInside := false; end; destructor TMIMEPart.Destroy; @@ -248,6 +268,7 @@ begin FDescription := ''; FBoundary := ''; FFileName := ''; + FAttachInside := False; FPartBody.Clear; FHeaders.Clear; FPrePart.Clear; @@ -280,6 +301,7 @@ begin PrePart.Assign(Value.PrePart); PostPart.Assign(Value.PostPart); MaxLineLength := Value.MaxLineLength; + FAttachInside := Value.AttachInside; end; {==============================================================================} @@ -342,6 +364,7 @@ begin Result := TMimePart.Create; Result.DefaultCharset := FDefaultCharset; FSubParts.Add(Result); + Result.SubLevel := FSubLevel + 1; end; {==============================================================================} @@ -374,7 +397,6 @@ begin Break; FHeaders.Add(s); end; - StringsTrim(FHeaders); DecodePartHeader; //extract prepart if FPrimaryCode = MP_MULTIPART then @@ -387,29 +409,39 @@ begin if s = '--' + FBoundary then Break; FPrePart.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); end; - StringsTrim(FPrePart); end; //extract body part if FPrimaryCode = MP_MULTIPART then begin repeat - Mime := AddSubPart; - while FLines.Count > x do + if CanSubPart then + begin + Mime := AddSubPart; + while FLines.Count > x do + begin + s := FLines[x]; + Inc(x); + if Pos('--' + FBoundary, s) = 1 then + Break; + Mime.Lines.Add(s); + end; + StringsTrim(Mime.Lines); + Mime.DecomposeParts; + end + else begin s := FLines[x]; Inc(x); - if Pos('--' + FBoundary, s) = 1 then - Break; - Mime.Lines.Add(s); + FPartBody.Add(s); end; - StringsTrim(Mime.Lines); - Mime.DecomposeParts; if x >= FLines.Count then break; until s = '--' + FBoundary + '--'; end; - if FPrimaryCode = MP_MESSAGE then + if (FPrimaryCode = MP_MESSAGE) and CanSubPart then begin Mime := AddSubPart; SkipEmpty; @@ -430,6 +462,8 @@ begin s := TrimRight(FLines[x]); Inc(x); FPartBody.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); end; StringsTrim(FPartBody); end; @@ -442,6 +476,8 @@ begin s := TrimRight(FLines[x]); Inc(x); FPostPart.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); end; StringsTrim(FPostPart); end; @@ -502,14 +538,12 @@ begin if FPrimaryCode = MP_MULTIPART then begin Flines.AddStrings(FPrePart); - Flines.Add(''); for n := 0 to GetSubPartCount - 1 do begin Flines.Add('--' + FBoundary); mime := GetSubPart(n); mime.ComposeParts; FLines.AddStrings(mime.Lines); - Flines.Add(''); end; Flines.Add('--' + FBoundary + '--'); Flines.AddStrings(FPostPart); @@ -522,70 +556,43 @@ begin mime := GetSubPart(0); mime.ComposeParts; FLines.AddStrings(mime.Lines); - Flines.Add(''); end; end else //if normal part begin FLines.AddStrings(FPartBody); - Flines.Add(''); end; end; {==============================================================================} procedure TMIMEPart.DecodePart; -const - CRLF = #13#10; var n: Integer; s: string; begin FDecodedLines.Clear; - for n := 0 to FPartBody.Count - 1 do - begin - s := FPartBody[n]; - case FEncodingCode of - ME_7BIT: - begin - if FPrimaryCode = MP_TEXT then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - s := s + CRLF; - end; - ME_8BIT: - begin - if FPrimaryCode = MP_TEXT then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - s := s + CRLF; - end; - ME_QUOTED_PRINTABLE: - begin - if s = '' then - s := CRLF + case FEncodingCode of + ME_QUOTED_PRINTABLE: + s := DecodeQuotedPrintable(FPartBody.Text); + ME_BASE64: + s := DecodeBase64(FPartBody.Text); + ME_UU, ME_XX: + begin + s := ''; + for n := 0 to FPartBody.Count - 1 do + if FEncodingCode = ME_UU then + s := s + DecodeUU(FPartBody[n]) else - if s[Length(s)] <> '=' then - s := s + CRLF; - s := DecodeQuotedPrintable(s); - if FPrimaryCode = MP_TEXT then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - end; - ME_BASE64: - begin - if s <> '' then - s := DecodeBase64(s); - if FPrimaryCode = MP_TEXT then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - end; - ME_UU: - if s <> '' then - s := DecodeUU(s); - ME_XX: - if s <> '' then - s := DecodeXX(s); - end; - FDecodedLines.Write(Pointer(s)^, Length(s)); + s := s + DecodeXX(FPartBody[n]); + end; + else + s := FPartBody.Text; end; + if FPrimaryCode = MP_TEXT then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + FDecodedLines.Write(Pointer(s)^, Length(s)); FDecodedLines.Seek(0, soFromBeginning); end; @@ -647,9 +654,9 @@ begin if Pos('CONTENT-ID:', su) = 1 then FContentID := SeparateRight(s, ':'); end; - if (PrimaryCode = MP_BINARY) and (FFileName = '') then + if FFileName = '' then FFileName := fn; - FFileName := InlineDecode(FFileName, getCurCP); + FFileName := InlineDecode(FFileName, FTargetCharset); FFileName := ExtractFileName(FFileName); end; @@ -687,7 +694,15 @@ begin end else begin - l.LoadFromStream(FDecodedLines); + if FPrimaryCode = MP_BINARY then + begin + 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]; @@ -695,8 +710,10 @@ begin s := CharsetConversion(s, FTargetCharset, FCharsetCode); if FEncodingCode = ME_QUOTED_PRINTABLE then begin - s := EncodeTriplet(s, '=', [Char(1)..Char(31), '=', Char(128)..Char(255)]); -// s := EncodeQuotedPrintable(s); + if FPrimaryCode = MP_BINARY then + s := EncodeQuotedPrintable(s) + else + s := EncodeTriplet(s, '=', [Char(0)..Char(31), '=', Char(127)..Char(255)]); repeat if Length(s) < FMaxLineLength then begin @@ -717,7 +734,7 @@ begin if x = 0 then x := FMaxLineLength; t := Copy(s, 1, x); - s := Copy(s, x + 1, Length(s) - x); + Delete(s, 1, x); if s <> '' then t := t + '='; end; @@ -727,6 +744,9 @@ begin else FPartBody.Add(s); end; + if (FPrimaryCode = MP_BINARY) + and (FEncodingCode = ME_QUOTED_PRINTABLE) then + FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '='; end; end; finally @@ -758,7 +778,7 @@ begin begin s := ''; if FFileName <> '' then - s := '; FileName="' + InlineCode(FFileName) + '"'; + s := '; FileName="' + InlineCodeEx(FileName, FTargetCharset) + '"'; FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); end; if FContentID <> '' then @@ -783,11 +803,11 @@ begin s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode); MP_MULTIPART: s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"'; - MP_MESSAGE: - s := FPrimary + '/' + FSecondary + ''; - MP_BINARY: - s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"'; + MP_MESSAGE, MP_BINARY: + s := FPrimary + '/' + FSecondary; end; + if FFileName <> '' then + s := s + '; name="' + InlineCodeEx(FileName, FTargetCharset) + '"'; FHeaders.Insert(0, 'Content-type: ' + s); end; @@ -878,16 +898,35 @@ begin FCharsetCode := GetCPFromID(Value); end; +function TMIMEPart.CanSubPart: boolean; +begin + Result := True; + if FMaxSubLevel <> -1 then + Result := FMaxSubLevel > FSubLevel; +end; + +function TMIMEPart.IsUUcode(Value: string): boolean; +begin + Value := UpperCase(Value); + Result := (pos('BEGIN ', Value) = 1) and (SeparateRight(Value, ' ') <> ''); +end; + {==============================================================================} function GenerateBoundary: string; var - x: Integer; + x, y: Integer; begin - Sleep(1); + y := GetTick; + x := y; + while TickDelta(y, x) = 0 do + begin + Sleep(1); + x := GetTick; + end; Randomize; - x := Random(MaxInt); - Result := IntToHex(x, 8) + '_Synapse_message_boundary'; + y := Random(MaxInt); + Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary'; end; end. diff --git a/nntpsend.pas b/nntpsend.pas index 4b3a110..3c14a33 100644 --- a/nntpsend.pas +++ b/nntpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.003.001 | +| Project : Ararat Synapse | 001.003.003 | |==============================================================================| | Content: NNTP client | |==============================================================================| @@ -42,7 +42,14 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -unit NNTPsend; +//RFC-977, RFC-2980 + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit nntpsend; interface @@ -51,7 +58,7 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, SynaUtil, SynaCode; + blcksock, synautil, synacode; const cNNTPProtocol = 'nntp'; diff --git a/pingsend.pas b/pingsend.pas index d5316bc..a0077b6 100644 --- a/pingsend.pas +++ b/pingsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.000.002 | +| Project : Ararat Synapse | 003.001.005 | |==============================================================================| | Content: PING sender | |==============================================================================| @@ -42,10 +42,14 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} {$R-} +{$H+} -unit PINGsend; +unit pingsend; interface @@ -56,13 +60,18 @@ uses Windows, {$ENDIF} SysUtils, - synsock, blcksock, SynaUtil; + synsock, blcksock, synautil; const ICMP_ECHO = 8; ICMP_ECHOREPLY = 0; + ICMP_UNREACH = 3; + ICMP_TIME_EXCEEDED = 11; +//rfc-2292 ICMP6_ECHO = 128; ICMP6_ECHOREPLY = 129; + ICMP6_UNREACH = 1; + ICMP6_TIME_EXCEEDED = 3; type TIcmpEchoHeader = record @@ -84,6 +93,17 @@ type proto: Byte; end; + TICMPError = ( + IE_NoError, + IE_Other, + IE_TTLExceed, + IE_UnreachOther, + IE_UnreachRoute, + IE_UnreachAdmin, + IE_UnreachAddr, + IE_UnreachPort + ); + TPINGSend = class(TSynaClient) private FSock: TICMPBlockSocket; @@ -94,9 +114,16 @@ type FPingTime: Integer; FIcmpEcho: Byte; FIcmpEchoReply: Byte; + FIcmpUnreach: Byte; + FReplyFrom: string; + FReplyType: byte; + FReplyCode: byte; + FReplyError: TICMPError; + FReplyErrorDesc: string; function Checksum(Value: string): Word; function Checksum6(Value: string): Word; function ReadPacket: Boolean; + procedure TranslateError; public function Ping(const Host: string): Boolean; constructor Create; @@ -104,10 +131,16 @@ type published property PacketSize: Integer read FPacketSize Write FPacketSize; property PingTime: Integer read FPingTime; + property ReplyFrom: string read FReplyFrom; + property ReplyType: byte read FReplyType; + property ReplyCode: byte read FReplyCode; + property ReplyError: TICMPError read FReplyError; + property ReplyErrorDesc: string read FReplyErrorDesc; property Sock: TICMPBlockSocket read FSock; end; function PingHost(const Host: string): Integer; +function TraceRouteHost(const Host: string): string; implementation @@ -140,11 +173,16 @@ var IPHeadPtr: ^TIPHeader; IpHdrLen: Integer; IcmpEchoHeaderPtr: ^TICMPEchoHeader; - n: Integer; t: Boolean; + x: cardinal; begin Result := False; FPingTime := -1; + FReplyFrom := ''; + FReplyType := 0; + FReplyCode := 0; + FReplyError := IE_NoError; + FReplyErrorDesc := ''; FSock.Bind(FIPInterface, cAnyPort); FSock.Connect(Host, '0'); if FSock.LastError <> 0 then @@ -154,32 +192,33 @@ begin begin FIcmpEcho := ICMP6_ECHO; FIcmpEchoReply := ICMP6_ECHOREPLY; + FIcmpUnreach := ICMP6_UNREACH; end else begin FIcmpEcho := ICMP_ECHO; FIcmpEchoReply := ICMP_ECHOREPLY; + FIcmpUnreach := ICMP_UNREACH; end; - FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize); + FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize); IcmpEchoHeaderPtr := Pointer(FBuffer); with IcmpEchoHeaderPtr^ do begin i_type := FIcmpEcho; i_code := 0; i_CheckSum := 0; - FId := Random(32767); + FId := System.Random(32767); i_Id := FId; TimeStamp := GetTick; Inc(FSeq); i_Seq := FSeq; - for n := Succ(SizeOf(TIcmpEchoHeader)) to Length(FBuffer) do - FBuffer[n] := #$55; + if fSock.IP6used then + i_CheckSum := CheckSum6(FBuffer) + else + i_CheckSum := CheckSum(FBuffer); end; - if fSock.IP6used then - IcmpEchoHeaderPtr^.i_CheckSum := CheckSum6(FBuffer) - else - IcmpEchoHeaderPtr^.i_CheckSum := CheckSum(FBuffer); FSock.SendString(FBuffer); + x := GetTick; repeat t := ReadPacket; if not t then @@ -200,31 +239,35 @@ begin IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; end; - until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho) and (IcmpEchoHeaderPtr^.i_id = FId); + until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho) + and ((IcmpEchoHeaderPtr^.i_id = FId) or (IcmpEchoHeaderPtr^.i_id = 0)); //it discard sometimes possible 'echoes' of previosly sended packet... if t then - if (IcmpEchoHeaderPtr^.i_type = FIcmpEchoReply) then begin - FPingTime := TickDelta(IcmpEchoHeaderPtr^.TimeStamp, GetTick); + FPingTime := TickDelta(x, GetTick); + FReplyFrom := FSock.GetRemoteSinIP; + FReplyType := IcmpEchoHeaderPtr^.i_type; + FReplyCode := IcmpEchoHeaderPtr^.i_code; + TranslateError; Result := True; end; end; function TPINGSend.Checksum(Value: string): Word; -type - TWordArray = array[0..0] of Word; var - WordArr: ^TWordArray; CkSum: DWORD; Num, Remain: Integer; - n: Integer; + n, i: Integer; begin Num := Length(Value) div 2; Remain := Length(Value) mod 2; - WordArr := Pointer(Value); CkSum := 0; + i := 1; for n := 0 to Num - 1 do - CkSum := CkSum + WordArr^[n]; + begin + CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i)); + inc(i, 2); + end; if Remain <> 0 then CkSum := CkSum + Ord(Value[Length(Value)]); CkSum := (CkSum shr 16) + (CkSum and $FFFF); @@ -252,30 +295,134 @@ begin s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value; ICMP6Ptr := Pointer(s); x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY, - @FSock.RemoteSin.IP6, SizeOf(FSock.RemoteSin.IP6), + @FSock.RemoteSin, SizeOf(FSock.RemoteSin), @ip6, SizeOf(ip6), @b, nil, nil); if x <> -1 then ICMP6Ptr^.in_dest := ip6.sin6_addr else - ICMP6Ptr^.in_dest := FSock.LocalSin.IP6.sin6_addr; - ICMP6Ptr^.in_source := FSock.RemoteSin.IP6.sin6_addr; + ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr; + ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr; ICMP6Ptr^.Length := synsock.htonl(Length(Value)); ICMP6Ptr^.proto := IPPROTO_ICMPV6; Result := Checksum(s); {$ENDIF} end; +procedure TPINGSend.TranslateError; +begin + if fSock.IP6used then + begin + case FReplyType of + ICMP6_ECHOREPLY: + FReplyError := IE_NoError; + ICMP6_TIME_EXCEEDED: + FReplyError := IE_TTLExceed; + ICMP6_UNREACH: + case FReplyCode of + 0: + FReplyError := IE_UnreachRoute; + 3: + FReplyError := IE_UnreachAddr; + 4: + FReplyError := IE_UnreachPort; + 1: + FReplyError := IE_UnreachAdmin; + else + FReplyError := IE_UnreachOther; + end; + else + FReplyError := IE_Other; + end; + end + else + begin + case FReplyType of + ICMP_ECHOREPLY: + FReplyError := IE_NoError; + ICMP_TIME_EXCEEDED: + FReplyError := IE_TTLExceed; + ICMP_UNREACH: + case FReplyCode of + 0: + FReplyError := IE_UnreachRoute; + 1: + FReplyError := IE_UnreachAddr; + 3: + FReplyError := IE_UnreachPort; + 13: + FReplyError := IE_UnreachAdmin; + else + FReplyError := IE_UnreachOther; + end; + else + FReplyError := IE_Other; + end; + end; + case FReplyError of + IE_NoError: + FReplyErrorDesc := ''; + IE_Other: + FReplyErrorDesc := 'Unknown error'; + IE_TTLExceed: + FReplyErrorDesc := 'TTL Exceeded'; + IE_UnreachOther: + FReplyErrorDesc := 'Unknown unreachable'; + IE_UnreachRoute: + FReplyErrorDesc := 'No route to destination'; + IE_UnreachAdmin: + FReplyErrorDesc := 'Administratively prohibited'; + IE_UnreachAddr: + FReplyErrorDesc := 'Address unreachable'; + IE_UnreachPort: + FReplyErrorDesc := 'Port unreachable'; + end; +end; + {==============================================================================} function PingHost(const Host: string): Integer; begin with TPINGSend.Create do try - Ping(Host); - Result := PingTime; + Result := -1; + if Ping(Host) then + if ReplyError = IE_NoError then + Result := PingTime; finally Free; end; end; +function TraceRouteHost(const Host: string): string; +var + Ping: TPingSend; + ttl : byte; +begin + Result := ''; + Ping := TPINGSend.Create; + try + ttl := 1; + repeat + ping.Sock.TTL := ttl; + inc(ttl); + if ttl > 30 then + Break; + if not ping.Ping(Host) then + begin + Result := Result + cAnyHost+ ' Timeout' + CRLF; + continue; + end; + if (ping.ReplyError <> IE_NoError) + and (ping.ReplyError <> IE_TTLExceed) then + begin + Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF; + break; + end; + Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF; + until ping.ReplyError = IE_NoError; + finally + Ping.Free; + end; +end; + end. diff --git a/pop3send.pas b/pop3send.pas index 31115b8..19eca41 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.008 | +| Project : Ararat Synapse | 002.001.010 | |==============================================================================| | Content: POP3 client | |==============================================================================| @@ -42,13 +42,14 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-1734 -//RFC-1939 -//RFC-2195 -//RFC-2449 -//RFC-2595 +//RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 -unit POP3send; +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit pop3send; interface @@ -57,7 +58,7 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, SynaUtil, SynaCode; + blcksock, synautil, synacode; const cPop3Protocol = 'pop3'; diff --git a/slogsend.pas b/slogsend.pas index aa94e9c..cf9b665 100644 --- a/slogsend.pas +++ b/slogsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.004 | +| Project : Ararat Synapse | 001.001.006 | |==============================================================================| | Content: SysLog client | |==============================================================================| @@ -44,15 +44,19 @@ // RFC-3164 +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$H+} -unit SLogSend; +unit slogsend; interface uses SysUtils, Classes, - blcksock, SynaUtil; + blcksock, synautil; const cSysLogProtocol = '514'; diff --git a/smtpsend.pas b/smtpsend.pas index 9de951d..4f82434 100644 --- a/smtpsend.pas +++ b/smtpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.002.008 | +| Project : Ararat Synapse | 003.002.011 | |==============================================================================| | Content: SMTP client | |==============================================================================| @@ -42,7 +42,15 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -unit SMTPsend; +//RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487, +//RFC-2554, RFC-2821 + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit smtpsend; interface @@ -51,7 +59,7 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, SynaUtil, SynaCode; + blcksock, synautil, synacode; const cSmtpProtocol = 'smtp'; @@ -561,7 +569,7 @@ begin begin s := MailTo; repeat - t := GetEmailAddr(fetch(s, ',')); + t := GetEmailAddr(FetchEx(s, ',', '"')); if t <> '' then Result := SMTP.MailTo(t); if not Result then diff --git a/snmpsend.pas b/snmpsend.pas index 365548d..11057e7 100644 --- a/snmpsend.pas +++ b/snmpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.006.002 | +| Project : Ararat Synapse | 002.006.004 | |==============================================================================| | Content: SNMP client | |==============================================================================| @@ -43,15 +43,19 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$H+} -unit SNMPSend; +unit snmpsend; interface uses Classes, SysUtils, - blckSock, SynaUtil, ASN1Util; + blcksock, synautil, asn1util; const cSnmpProtocol = '161'; diff --git a/snmptrap.pas b/snmptrap.pas index 2c49ad9..30f4e51 100644 --- a/snmptrap.pas +++ b/snmptrap.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.002 | +| Project : Ararat Synapse | 002.003.004 | |==============================================================================| | Content: SNMP traps | |==============================================================================| @@ -43,15 +43,19 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$H+} -unit SNMPTrap; +unit snmptrap; interface uses Classes, SysUtils, - blckSock, SynaUtil, ASN1Util, SNMPSend; + blcksock, synautil, asn1util, snmpsend; const cSnmpTrapProtocol = '162'; diff --git a/sntpsend.pas b/sntpsend.pas index 9d23485..0e32de0 100644 --- a/sntpsend.pas +++ b/sntpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.002.003 | +| Project : Ararat Synapse | 002.002.007 | |==============================================================================| | Content: SNTP client | |==============================================================================| @@ -43,15 +43,19 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$H+} -unit SNTPsend; +unit sntpsend; interface uses SysUtils, - synsock, blcksock, SynaUtil; + synsock, blcksock, synautil; const cNtpProtocol = 'ntp'; @@ -95,8 +99,8 @@ type function GetSNTP: Boolean; function GetNTP: Boolean; function GetBroadcastNTP: Boolean; - published property NTPReply: TNtp read FNTPReply; + published property NTPTime: TDateTime read FNTPTime; property NTPOffset: Double read FNTPOffset; property NTPDelay: Double read FNTPDelay; @@ -171,12 +175,12 @@ var x: Integer; begin Result := False; - FSock.Bind(FIPInterface, cAnyPort); + FSock.Bind(FIPInterface, FTargetPort); FBuffer := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then begin x := Length(FBuffer); - if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FTargetHost) then + if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then if x >= SizeOf(NTPReply) then begin NtpPtr := Pointer(FBuffer); diff --git a/synachar.pas b/synachar.pas index 70d2210..165569b 100644 --- a/synachar.pas +++ b/synachar.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 004.000.005 | +| Project : Ararat Synapse | 004.000.008 | |==============================================================================| | Content: Charset conversion support | |==============================================================================| @@ -42,9 +42,13 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$H+} -unit SynaChar; +unit synachar; interface @@ -644,7 +648,7 @@ const (0); //remove diakritics from Czech - Replace_Czech: array[0..55] of Word = + Replace_Czech: array[0..59] of Word = ( $00E1, $0061, $010D, $0063, @@ -653,6 +657,7 @@ const $00E9, $0065, $011B, $0065, $00ED, $0069, + $0148, $006E, $00F3, $006F, $0159, $0072, $0161, $0073, @@ -666,10 +671,11 @@ const $00C9, $0045, $011A, $0045, $00CD, $0049, + $0147, $004E, $00D3, $004F, $0158, $0052, $0160, $0053, - $0164, $0053, + $0164, $0054, $00DA, $0055, $016E, $0055, $00DD, $0059, @@ -701,7 +707,7 @@ uses Windows, {$ENDIF} SysUtils, - SynaUtil, SynaCode; + synautil, synacode; const NotFoundChar = '_'; diff --git a/synacode.pas b/synacode.pas index f9b0928..50fe271 100644 --- a/synacode.pas +++ b/synacode.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.007.001 | +| Project : Ararat Synapse | 001.008.007 | |==============================================================================| | Content: Coding and decoding support | |==============================================================================| @@ -42,9 +42,14 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$R-} +{$H+} -unit SynaCode; +unit synacode; interface @@ -241,29 +246,72 @@ type function DecodeTriplet(const Value: string; Delimiter: Char): string; var - x, l: Integer; + x, l, lv: Integer; c: Char; - s: string; + b: Byte; + bad: Boolean; begin - SetLength(Result, Length(Value)); + lv := Length(Value); + SetLength(Result, lv); x := 1; l := 1; - while x <= Length(Value) do + while x <= lv do begin c := Value[x]; Inc(x); if c <> Delimiter then - Result[l] := c + begin + Result[l] := c; + Inc(l); + end else - if x < Length(Value) then + if x < lv then begin - s := Copy(Value, x, 2); - Inc(x, 2); - Result[l] := Char(StrToIntDef('$' + s, 32)) + Case Value[x] Of + #13: + if (Value[x + 1] = #10) then + Inc(x, 2) + else + Inc(x); + #10: + if (Value[x + 1] = #13) then + Inc(x, 2) + else + Inc(x); + else + begin + bad := False; + Case Value[x] Of + '0'..'9': b := (Byte(Value[x]) - 48) Shl 4; + 'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; + else + begin + b := 0; + bad := True; + end; + end; + Case Value[x + 1] Of + '0'..'9': b := b Or (Byte(Value[x + 1]) - 48); + 'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); + else + bad := True; + end; + if bad then + begin + Result[l] := c; + Inc(l); + end + else + begin + Inc(x, 2); + Result[l] := Char(b); + Inc(l); + end; + end; + end; end else break; - Inc(l); end; Dec(l); SetLength(Result, l); @@ -322,7 +370,7 @@ end; function EncodeQuotedPrintable(const Value: string): string; begin Result := EncodeTriplet(Value, '=', SpecialChar + - [Char(1)..Char(31), Char(128)..Char(255)]); + [Char(0)..Char(31), Char(127)..Char(255)]); end; {==============================================================================} @@ -349,7 +397,7 @@ begin SetLength(Result, Length(Value)); x := 1; l := 1; - while x < Length(Value) do + while x <= Length(Value) do begin for n := 0 to 3 do begin @@ -382,45 +430,66 @@ begin end; {==============================================================================} - function Decode4to3Ex(const Value, Table: string): string; -var - x, y, n, l: Integer; - d: array[0..3] of Byte; -begin - SetLength(Result, Length(Value)); - x := 1; - l := 1; - while x < Length(Value) do - begin - for n := 0 to 3 do - begin - if x > Length(Value) then - d[n] := 64 - else - begin - y := Ord(Value[x]); - if (y < 33) or (y > 127) then - d[n] := 64 - else - d[n] := Ord(Table[y - 32]); - end; - Inc(x); - end; - Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); - Inc(l); - if d[2] <> 64 then - begin - Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); - Inc(l); - if d[3] <> 64 then - begin - Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F)); - Inc(l); - end; - end; +type + TDconvert = record + case byte of + 0: (a0, a1, a2, a3: char); + 1: (i: integer); end; - Dec(l); +var + x, y, l, lv: Integer; + d: TDconvert; + dl: integer; + c: byte; + p: ^char; +begin + lv := Length(Value); + SetLength(Result, lv); + x := 1; + dl := 4; + d.i := 0; + p := pointer(result); + while x <= lv do + begin + y := Ord(Value[x]); + if y in [33..127] then + c := Ord(Table[y - 32]) + else + c := 64; + Inc(x); + if c > 63 then + continue; + d.i := (d.i shl 6) or c; + dec(dl); + if dl <> 0 then + continue; + p^ := d.a2; + inc(p); + p^ := d.a1; + inc(p); + p^ := d.a0; + inc(p); + d.i := 0; + dl := 4; + end; + case dl of + 1: + begin + d.i := d.i shr 2; + p^ := d.a1; + inc(p); + p^ := d.a0; + inc(p); + end; + 2: + begin + d.i := d.i shr 4; + p^ := d.a0; + inc(p); + end; + end; + l := integer(p) - integer(pointer(result)); SetLength(Result, l); end; @@ -516,6 +585,7 @@ begin s := Copy(Value, 2, x); if s = '' then Exit; + s := s + StringOfChar(' ', x - length(s)); Result := Decode4to3(s, uut); end; @@ -554,6 +624,7 @@ begin s := Copy(Value, 2, x); if s = '' then Exit; + s := s + StringOfChar(' ', x - length(s)); Result := Decode4to3(s, TableXX); end; @@ -772,7 +843,7 @@ begin Dec(Len, T); Index := T; end; - while Len >= 64 do + while Len > 64 do begin Move(Data[Index + 1], Bufchar, 64); MD5Transform(State, Buflong); @@ -799,14 +870,15 @@ begin BufChar[P] := $80; Inc(P); Cnt := 64 - 1 - Cnt; - if Cnt < 8 then - begin - FillChar(BufChar[P], Cnt, #0); - MD5Transform(State, BufLong); - FillChar(BufChar, 56, #0); - end - else - FillChar(BufChar[P], Cnt - 8, #0); + if Cnt > 0 then + if Cnt < 8 then + begin + FillChar(BufChar[P], Cnt, #0); + MD5Transform(State, BufLong); + FillChar(BufChar, 56, #0); + end + else + FillChar(BufChar[P], Cnt - 8, #0); BufLong[14] := Count[0]; BufLong[15] := Count[1]; MD5Transform(State, BufLong); diff --git a/synafpc.pas b/synafpc.pas new file mode 100644 index 0000000..b17ad70 --- /dev/null +++ b/synafpc.pas @@ -0,0 +1,106 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: Utils for FreePascal compatibility | +|==============================================================================| +| Copyright (c)1999-2003, 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)2003. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit synafpc; + +interface + +{$IFDEF LINUX} + {$IFDEF FPC} +uses + Libc, + dynlibs; + +type + HMODULE = Longint; + +function LoadLibrary(ModuleName: PChar): HMODULE; +function FreeLibrary(Module: HMODULE): LongBool; +function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +procedure Sleep(milliseconds: Cardinal); + + {$ENDIF} +{$ENDIF} + + +implementation + +{==============================================================================} +{$IFDEF LINUX} + {$IFDEF FPC} +function LoadLibrary(ModuleName: PChar): HMODULE; +begin + Result := HMODULE(dynlibs.LoadLibrary(Modulename)); +end; + +function FreeLibrary(Module: HMODULE): LongBool; +begin + Result := dynlibs.UnloadLibrary(pointer(Module)); +end; + +function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; +begin + Result := dynlibs.GetProcedureAddress(pointer(Module), Proc); +end; + +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +begin + Result := 0; +end; + +procedure Sleep(milliseconds: Cardinal); +begin + usleep(milliseconds * 1000); // usleep is in microseconds +end; + + {$ENDIF} +{$ENDIF} + +end. diff --git a/synamisc.pas b/synamisc.pas index 42ce6fc..f0ffbf0 100644 --- a/synamisc.pas +++ b/synamisc.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.000.006 | +| Project : Ararat Synapse | 001.001.002 | |==============================================================================| | Content: misc. procedures and functions | |==============================================================================| @@ -42,9 +42,13 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} +{$H+} -unit SynaMisc; +unit synamisc; interface @@ -57,11 +61,16 @@ interface {$ENDIF} uses - SynaUtil, blcksock, SysUtils, Classes, + synautil, blcksock, SysUtils, Classes, {$IFDEF LINUX} Libc; {$ELSE} - Windows, Wininet; +{$IFDEF FPC} + winver, +{$ELSE} + Wininet, +{$ENDIF} + Windows; {$ENDIF} Type @@ -258,6 +267,13 @@ begin Result.Bypass := ''; end; {$ELSE} +{$IFDEF FPC} +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; +end; +{$ELSE} var ProxyInfo: PInternetProxyInfo; Err: Boolean; @@ -308,6 +324,7 @@ begin end; end; {$ENDIF} +{$ENDIF} {==============================================================================} diff --git a/synassl.pas b/synassl.pas index 2662475..e5cbcea 100644 --- a/synassl.pas +++ b/synassl.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.007.001 | +| Project : Ararat Synapse | 002.001.002 | |==============================================================================| | Content: SSL support | |==============================================================================| @@ -44,9 +44,13 @@ { Special thanks to Gregor Ibic (Intelicom d.o.o., http://www.intelicom.si) - for good inspiration about SSL programming. + for good inspiration about begin with SSL programming. } +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} {$IFDEF VER125} {$DEFINE BCB} {$ENDIF} @@ -55,25 +59,28 @@ Special thanks to Gregor Ibic (*$HPPEMIT 'namespace Synassl { using System::Shortint; }' *) {$ENDIF} -unit SynaSSL; +unit synassl; interface uses {$IFDEF LINUX} + {$IFDEF FPC} + synafpc, + {$ENDIF} Libc, SysUtils; {$ELSE} Windows; {$ENDIF} -const +var {$IFDEF LINUX} - DLLSSLName = 'libssl.so'; - DLLUtilName = 'libcrypto.so'; + DLLSSLName: string = 'libssl.so'; + DLLUtilName: string = 'libcrypto.so'; {$ELSE} - DLLSSLName = 'ssleay32.dll'; - DLLSSLName2 = 'libssl32.dll'; - DLLUtilName = 'libeay32.dll'; + DLLSSLName: string = 'ssleay32.dll'; + DLLSSLName2: string = 'libssl32.dll'; + DLLUtilName: string = 'libeay32.dll'; {$ENDIF} type @@ -84,14 +91,22 @@ type PX509_NAME = Pointer; PEVP_MD = Pointer; PInteger = ^Integer; + PBIO_METHOD = Pointer; + PBIO = Pointer; const - EVP_MAX_MD_SIZE = 16+20; + EVP_MAX_MD_SIZE = 16 + 20; + SSL_ERROR_NONE = 0; SSL_ERROR_SSL = 1; SSL_ERROR_WANT_READ = 2; SSL_ERROR_WANT_WRITE = 3; + SSL_ERROR_WANT_X509_LOOKUP = 4; + SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno SSL_ERROR_ZERO_RETURN = 6; + SSL_ERROR_WANT_CONNECT = 7; + SSL_ERROR_WANT_ACCEPT = 8; + SSL_OP_NO_SSLv2 = $01000000; SSL_OP_NO_SSLv3 = $02000000; SSL_OP_NO_TLSv1 = $04000000; @@ -99,51 +114,111 @@ const SSL_VERIFY_NONE = $00; SSL_VERIFY_PEER = $01; + X509_V_OK = 0; + X509_V_ILLEGAL = 1; + X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2; + X509_V_ERR_UNABLE_TO_GET_CRL = 3; + X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4; + X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5; + X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6; + X509_V_ERR_CERT_SIGNATURE_FAILURE = 7; + X509_V_ERR_CRL_SIGNATURE_FAILURE = 8; + X509_V_ERR_CERT_NOT_YET_VALID = 9; + X509_V_ERR_CERT_HAS_EXPIRED = 10; + X509_V_ERR_CRL_NOT_YET_VALID = 11; + X509_V_ERR_CRL_HAS_EXPIRED = 12; + X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13; + X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14; + X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15; + X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16; + X509_V_ERR_OUT_OF_MEM = 17; + X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18; + X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19; + X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20; + X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21; + X509_V_ERR_CERT_CHAIN_TOO_LONG = 22; + X509_V_ERR_CERT_REVOKED = 23; + X509_V_ERR_INVALID_CA = 24; + X509_V_ERR_PATH_LENGTH_EXCEEDED = 25; + X509_V_ERR_INVALID_PURPOSE = 26; + X509_V_ERR_CERT_UNTRUSTED = 27; + X509_V_ERR_CERT_REJECTED = 28; + //These are 'informational' when looking for issuer cert + X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29; + X509_V_ERR_AKID_SKID_MISMATCH = 30; + X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31; + X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32; + X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33; + X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34; + //The application is not happy + X509_V_ERR_APPLICATION_VERIFICATION = 50; + var SSLLibHandle: Integer = 0; SSLUtilHandle: Integer = 0; - SSLLibName: string = ''; + SSLLibFile: string = ''; + SSLUtilFile: string = ''; // libssl.dll - SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil; - SslLibraryInit : function:Integer cdecl = nil; - SslLoadErrorStrings : procedure cdecl = nil; - SslCtxSetCipherList : function(arg0: PSSL_CTX; str: PChar):Integer cdecl = nil; - SslCtxNew : function(meth: PSSL_METHOD):PSSL_CTX cdecl = nil; - SslCtxFree : procedure(arg0: PSSL_CTX) cdecl = nil; - SslSetFd : function(s: PSSL; fd: Integer):Integer cdecl = nil; - SslMethodV23 : function:PSSL_METHOD cdecl = nil; - SslCtxUsePrivateKeyFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil; - 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; - SslConnect : function(ssl: PSSL):Integer cdecl = nil; - SslShutdown : function(ssl: PSSL):Integer cdecl = nil; - SslRead : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; - SslPeek : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; - SslWrite : function(ssl: PSSL; const buf: PChar; num: Integer):Integer cdecl = nil; - SslPending : function(ssl: PSSL):Integer cdecl = nil; - SslGetVersion : function(ssl: PSSL):PChar cdecl = nil; - SslGetPeerCertificate : function(ssl: PSSL):PX509 cdecl = nil; - SslCtxSetVerify : procedure(ctx: PSSL_CTX; mode: Integer; arg2: Pointer) cdecl = nil; + function SslGetError(s: PSSL; ret_code: Integer):Integer; + function SslLibraryInit:Integer; + procedure SslLoadErrorStrings; + function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; + function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; + procedure SslCtxFree(arg0: PSSL_CTX); + function SslSetFd(s: PSSL; fd: Integer):Integer; + function SslMethodV2:PSSL_METHOD; + function SslMethodV3:PSSL_METHOD; + function SslMethodTLSV1:PSSL_METHOD; + function SslMethodV23:PSSL_METHOD; + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; + function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; + function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; + procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: Pointer); + procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: Pointer); + function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; + function SslNew(ctx: PSSL_CTX):PSSL; + procedure SslFree(ssl: PSSL); + function SslAccept(ssl: PSSL):Integer; + function SslConnect(ssl: PSSL):Integer; + function SslShutdown(ssl: PSSL):Integer; + function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; + function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; + function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; + function SslPending(ssl: PSSL):Integer; + function SslGetVersion(ssl: PSSL):PChar; + function SslGetPeerCertificate(ssl: PSSL):PX509; + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); + function SSLGetCurrentCipher(s: PSSL):pointer; + function SSLCipherGetName(c: pointer):PChar; + function SSLCipherGetBits(c: pointer; alg_bits: PInteger):Integer; + function SSLGetVerifyResult(ssl: PSSL):Integer; // libeay.dll - SslX509Free : procedure(x: PX509) cdecl = nil; - SslX509NameOneline : function(a: PX509_NAME; buf: PChar; size: Integer):PChar cdecl = nil; - SslX509GetSubjectName : function(a: PX509):PX509_NAME cdecl = nil; - SslX509GetIssuerName : function(a: PX509):PX509_NAME cdecl = nil; - SslX509NameHash : function(x: PX509_NAME):Cardinal cdecl = nil; - SslX509Digest : function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer cdecl = nil; - SslEvpMd5 : function:PEVP_MD cdecl = nil; - ErrErrorString : function(e: integer; buf: PChar): PChar cdecl = nil; - ErrGetError : function: integer cdecl = nil; - ErrClearError : procedure cdecl = nil; + procedure SslX509Free(x: PX509); + function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; + function SslX509GetSubjectName(a: PX509):PX509_NAME; + function SslX509GetIssuerName(a: PX509):PX509_NAME; + function SslX509NameHash(x: PX509_NAME):Cardinal; + function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; + function SslEvpMd5:PEVP_MD; + function ErrErrorString(e: integer; buf: PChar): PChar; + function ErrGetError: integer; + procedure ErrClearError; + procedure ErrFreeStrings; + procedure ErrRemoveState(pid: integer); + procedure EVPcleanup; + procedure CRYPTOcleanupAllExData; + procedure RandScreen; + function BioNew(b: PBIO_METHOD): PBIO; + procedure BioFreeAll(b: PBIO); + function BioSMem: PBIO_METHOD; + function BioCtrlPending(b: PBIO): integer; + function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; + function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; + function X509print(b: PBIO; a: PX509): integer; +function IsSSLloaded: Boolean; function InitSSLInterface: Boolean; function DestroySSLInterface: Boolean; @@ -151,77 +226,656 @@ implementation uses SyncObjs; +type +// libssl.dll + TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl; + TSslLibraryInit = function:Integer; cdecl; + TSslLoadErrorStrings = procedure; cdecl; + TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PChar):Integer; cdecl; + TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl; + TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl; + TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl; + TSslMethodV2 = function:PSSL_METHOD; cdecl; + TSslMethodV3 = function:PSSL_METHOD; cdecl; + TSslMethodTLSV1 = function:PSSL_METHOD; cdecl; + TSslMethodV23 = function:PSSL_METHOD; cdecl; + TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; cdecl; + TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PChar):Integer; cdecl; + TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl; + TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: Pointer); cdecl; + TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: Pointer); cdecl; + TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; cdecl; + TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl; + TSslFree = procedure(ssl: PSSL); cdecl; + TSslAccept = function(ssl: PSSL):Integer; cdecl; + TSslConnect = function(ssl: PSSL):Integer; cdecl; + TSslShutdown = function(ssl: PSSL):Integer; cdecl; + TSslRead = function(ssl: PSSL; buf: PChar; num: Integer):Integer; cdecl; + TSslPeek = function(ssl: PSSL; buf: PChar; num: Integer):Integer; cdecl; + TSslWrite = function(ssl: PSSL; const buf: PChar; num: Integer):Integer; cdecl; + TSslPending = function(ssl: PSSL):Integer; cdecl; + TSslGetVersion = function(ssl: PSSL):PChar; cdecl; + TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl; + TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); cdecl; + TSSLGetCurrentCipher = function(s: PSSL):pointer; cdecl; + TSSLCipherGetName = function(c: pointer):PChar; cdecl; + TSSLCipherGetBits = function(c: pointer; alg_bits: PInteger):Integer; cdecl; + TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl; + +// libeay.dll + TSslX509Free = procedure(x: PX509); cdecl; + TSslX509NameOneline = function(a: PX509_NAME; buf: PChar; size: Integer):PChar; cdecl; + TSslX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; + TSslX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; + TSslX509NameHash = function(x: PX509_NAME):Cardinal; cdecl; + TSslX509Digest = function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; cdecl; + TSslEvpMd5 = function:PEVP_MD; cdecl; + TErrErrorString = function(e: integer; buf: PChar): PChar; cdecl; + TErrGetError = function: integer; cdecl; + TErrClearError = procedure; cdecl; + TErrFreeStrings = procedure; cdecl; + TErrRemoveState = procedure(pid: integer); cdecl; + TEVPcleanup = procedure; cdecl; + TCRYPTOcleanupAllExData = procedure; cdecl; + TRandScreen = procedure; cdecl; + TBioNew = function(b: PBIO_METHOD): PBIO; cdecl; + TBioFreeAll = procedure(b: PBIO); cdecl; + TBioSMem = function: PBIO_METHOD; cdecl; + TBioCtrlPending = function(b: PBIO): integer; cdecl; + TBioRead = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl; + TBioWrite = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl; + TX509print = function(b: PBIO; a: PX509): integer; cdecl; + +var +// libssl.dll + _SslGetError: TSslGetError = nil; + _SslLibraryInit: TSslLibraryInit = nil; + _SslLoadErrorStrings: TSslLoadErrorStrings = nil; + _SslCtxSetCipherList: TSslCtxSetCipherList = nil; + _SslCtxNew: TSslCtxNew = nil; + _SslCtxFree: TSslCtxFree = nil; + _SslSetFd: TSslSetFd = nil; + _SslMethodV2: TSslMethodV2 = nil; + _SslMethodV3: TSslMethodV3 = nil; + _SslMethodTLSV1: TSslMethodTLSV1 = nil; + _SslMethodV23: TSslMethodV23 = nil; + _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil; + _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil; + _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil; + _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil; + _SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil; + _SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil; + _SslNew: TSslNew = nil; + _SslFree: TSslFree = nil; + _SslAccept: TSslAccept = nil; + _SslConnect: TSslConnect = nil; + _SslShutdown: TSslShutdown = nil; + _SslRead: TSslRead = nil; + _SslPeek: TSslPeek = nil; + _SslWrite: TSslWrite = nil; + _SslPending: TSslPending = nil; + _SslGetVersion: TSslGetVersion = nil; + _SslGetPeerCertificate: TSslGetPeerCertificate = nil; + _SslCtxSetVerify: TSslCtxSetVerify = nil; + _SSLGetCurrentCipher: TSSLGetCurrentCipher = nil; + _SSLCipherGetName: TSSLCipherGetName = nil; + _SSLCipherGetBits: TSSLCipherGetBits = nil; + _SSLGetVerifyResult: TSSLGetVerifyResult = nil; + +// libeay.dll + _SslX509Free: TSslX509Free = nil; + _SslX509NameOneline: TSslX509NameOneline = nil; + _SslX509GetSubjectName: TSslX509GetSubjectName = nil; + _SslX509GetIssuerName: TSslX509GetIssuerName = nil; + _SslX509NameHash: TSslX509NameHash = nil; + _SslX509Digest: TSslX509Digest = nil; + _SslEvpMd5: TSslEvpMd5 = nil; + _ErrErrorString: TErrErrorString = nil; + _ErrGetError: TErrGetError = nil; + _ErrClearError: TErrClearError = nil; + _ErrFreeStrings: TErrFreeStrings = nil; + _ErrRemoveState: TErrRemoveState = nil; + _EVPcleanup: TEVPcleanup = nil; + _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil; + _RandScreen: TRandScreen = nil; + _BioNew: TBioNew = nil; + _BioFreeAll: TBioFreeAll = nil; + _BioSMem: TBioSMem = nil; + _BioCtrlPending: TBioCtrlPending = nil; + _BioRead: TBioRead = nil; + _BioWrite: TBioWrite = nil; + _X509print: TX509print = nil; + var SSLCS: TCriticalSection; - SSLCount: Integer = 0; + SSLloaded: boolean = false; + +// libssl.dll +function SslGetError(s: PSSL; ret_code: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslGetError) then + Result := _SslGetError(s, ret_code) + else + Result := SSL_ERROR_SSL; +end; + +function SslLibraryInit:Integer; +begin + if InitSSLInterface and Assigned(_SslLibraryInit) then + Result := _SslLibraryInit + else + Result := 1; +end; + +procedure SslLoadErrorStrings; +begin + if InitSSLInterface and Assigned(_SslLoadErrorStrings) then + _SslLoadErrorStrings; +end; + +function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxSetCipherList) then + Result := _SslCtxSetCipherList(arg0, str) + else + Result := 0; +end; + +function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; +begin + if InitSSLInterface and Assigned(_SslCtxNew) then + Result := _SslCtxNew(meth) + else + Result := nil; +end; + +procedure SslCtxFree(arg0: PSSL_CTX); +begin + if InitSSLInterface and Assigned(_SslCtxFree) then + _SslCtxFree(arg0); +end; + +function SslSetFd(s: PSSL; fd: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslSetFd) then + Result := _SslSetFd(s, fd) + else + Result := 0; +end; + +function SslMethodV2:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodV2) then + Result := _SslMethodV2 + else + Result := nil; +end; + +function SslMethodV3:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodV3) then + Result := _SslMethodV3 + else + Result := nil; +end; + +function SslMethodTLSV1:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodTLSV1) then + Result := _SslMethodTLSV1 + else + Result := nil; +end; + +function SslMethodV23:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodV23) then + Result := _SslMethodV23 + else + Result := nil; +end; + +function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then + Result := _SslCtxUsePrivateKeyFile(ctx, _file, _type) + else + Result := 0; +end; + +function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificateChainFile) then + Result := _SslCtxUseCertificateChainFile(ctx, _file) + else + Result := 0; +end; + +function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxCheckPrivateKeyFile) then + Result := _SslCtxCheckPrivateKeyFile(ctx) + else + Result := 0; +end; + +procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: Pointer); +begin + if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCb) then + _SslCtxSetDefaultPasswdCb(ctx, cb); +end; + +procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: Pointer); +begin + if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCbUserdata) then + _SslCtxSetDefaultPasswdCbUserdata(ctx, u); +end; + +function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then + Result := _SslCtxLoadVerifyLocations(ctx, CAfile, CApath) + else + Result := 0; +end; + +function SslNew(ctx: PSSL_CTX):PSSL; +begin + if InitSSLInterface and Assigned(_SslNew) then + Result := _SslNew(ctx) + else + Result := nil; +end; + +procedure SslFree(ssl: PSSL); +begin + if InitSSLInterface and Assigned(_SslFree) then + _SslFree(ssl); +end; + +function SslAccept(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslAccept) then + Result := _SslAccept(ssl) + else + Result := -1; +end; + +function SslConnect(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslConnect) then + Result := _SslConnect(ssl) + else + Result := -1; +end; + +function SslShutdown(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslShutdown) then + Result := _SslShutdown(ssl) + else + Result := -1; +end; + +function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslRead) then + Result := _SslRead(ssl, buf, num) + else + Result := -1; +end; + +function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslPeek) then + Result := _SslPeek(ssl, buf, num) + else + Result := -1; +end; + +function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslWrite) then + Result := _SslWrite(ssl, buf, num) + else + Result := -1; +end; + +function SslPending(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslPending) then + Result := _SslPending(ssl) + else + Result := 0; +end; + +function SslGetVersion(ssl: PSSL):PChar; +begin + if InitSSLInterface and Assigned(_SslGetVersion) then + Result := _SslGetVersion(ssl) + else + Result := nil; +end; + +function SslGetPeerCertificate(ssl: PSSL):PX509; +begin + if InitSSLInterface and Assigned(_SslGetPeerCertificate) then + Result := _SslGetPeerCertificate(ssl) + else + Result := nil; +end; + +procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); +begin + if InitSSLInterface and Assigned(_SslCtxSetVerify) then + _SslCtxSetVerify(ctx, mode, arg2); +end; + +function SSLGetCurrentCipher(s: PSSL):pointer; +begin + if InitSSLInterface and Assigned(_SSLGetCurrentCipher) then + Result := _SSLGetCurrentCipher(s) + else + Result := nil; +end; + +function SSLCipherGetName(c: pointer):PChar; +begin + if InitSSLInterface and Assigned(_SSLCipherGetName) then + Result := _SSLCipherGetName(c) + else + Result := nil; +end; + +function SSLCipherGetBits(c: pointer; alg_bits: PInteger):Integer; +begin + if InitSSLInterface and Assigned(_SSLCipherGetBits) then + Result := _SSLCipherGetBits(c, alg_bits) + else + Result := 0; +end; + +function SSLGetVerifyResult(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SSLGetVerifyResult) then + Result := _SSLGetVerifyResult(ssl) + else + Result := X509_V_ERR_APPLICATION_VERIFICATION; +end; + +// libeay.dll +procedure SslX509Free(x: PX509); +begin + if InitSSLInterface and Assigned(_SslX509Free) then + _SslX509Free(x); +end; + +function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; +begin + if InitSSLInterface and Assigned(_SslX509NameOneline) then + Result := _SslX509NameOneline(a, buf,size) + else + Result := nil; +end; + +function SslX509GetSubjectName(a: PX509):PX509_NAME; +begin + if InitSSLInterface and Assigned(_SslX509GetSubjectName) then + Result := _SslX509GetSubjectName(a) + else + Result := nil; +end; + +function SslX509GetIssuerName(a: PX509):PX509_NAME; +begin + if InitSSLInterface and Assigned(_SslX509GetIssuerName) then + Result := _SslX509GetIssuerName(a) + else + Result := nil; +end; + +function SslX509NameHash(x: PX509_NAME):Cardinal; +begin + if InitSSLInterface and Assigned(_SslX509NameHash) then + Result := _SslX509NameHash(x) + else + Result := 0; +end; + +function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; +begin + if InitSSLInterface and Assigned(_SslX509Digest) then + Result := _SslX509Digest(data, _type, md, len) + else + Result := 0; +end; + +function SslEvpMd5:PEVP_MD; +begin + if InitSSLInterface and Assigned(_SslEvpMd5) then + Result := _SslEvpMd5 + else + Result := nil; +end; + +function ErrErrorString(e: integer; buf: PChar): PChar; +begin + if InitSSLInterface and Assigned(_ErrErrorString) then + Result := _ErrErrorString(e, buf) + else + Result := nil; +end; + +function ErrGetError: integer; +begin + if InitSSLInterface and Assigned(_ErrGetError) then + Result := _ErrGetError + else + Result := SSL_ERROR_SSL; +end; + +procedure ErrClearError; +begin + if InitSSLInterface and Assigned(_ErrClearError) then + _ErrClearError; +end; + +procedure ErrFreeStrings; +begin + if InitSSLInterface and Assigned(_ErrFreeStrings) then + _ErrFreeStrings; +end; + +procedure ErrRemoveState(pid: integer); +begin + if InitSSLInterface and Assigned(_ErrRemoveState) then + _ErrRemoveState(pid); +end; + +procedure EVPcleanup; +begin + if InitSSLInterface and Assigned(_EVPcleanup) then + _EVPcleanup; +end; + +procedure CRYPTOcleanupAllExData; +begin + if InitSSLInterface and Assigned(_CRYPTOcleanupAllExData) then + _CRYPTOcleanupAllExData; +end; + +procedure RandScreen; +begin + if InitSSLInterface and Assigned(_RandScreen) then + _RandScreen; +end; + +function BioNew(b: PBIO_METHOD): PBIO; +begin + if InitSSLInterface and Assigned(_BioNew) then + Result := _BioNew(b) + else + Result := nil; +end; + +procedure BioFreeAll(b: PBIO); +begin + if InitSSLInterface and Assigned(_BioFreeAll) then + _BioFreeAll(b); +end; + +function BioSMem: PBIO_METHOD; +begin + if InitSSLInterface and Assigned(_BioSMem) then + Result := _BioSMem + else + Result := nil; +end; + +function BioCtrlPending(b: PBIO): integer; +begin + if InitSSLInterface and Assigned(_BioCtrlPending) then + Result := _BioCtrlPending(b) + else + Result := 0; +end; + +function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; +begin + if InitSSLInterface and Assigned(_BioRead) then + Result := _BioRead(b, Buf, Len) + else + Result := -2; +end; + +function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; +begin + if InitSSLInterface and Assigned(_BioWrite) then + Result := _BioWrite(b, Buf, Len) + else + Result := -2; +end; + +function X509print(b: PBIO; a: PX509): integer; +begin + if InitSSLInterface and Assigned(_X509print) then + Result := _X509print(b, a) + else + Result := 0; +end; + function InitSSLInterface: Boolean; +var + s: string; + x: integer; begin - Result := False; SSLCS.Enter; try - if SSLCount = 0 then + if not IsSSLloaded then begin -{$IFDEF LINUX} - SSLLibHandle := HMODULE(dlopen(DLLSSLName, RTLD_GLOBAL)); - SSLLibName := DLLSSLName; - SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL)); -{$ELSE} SSLLibHandle := LoadLibrary(PChar(DLLSSLName)); - SSLLibName := DLLSSLName; - if (SSLLibHandle = 0) then - begin - SSLLibHandle := LoadLibrary(PChar(DLLSSLName2)); - SSLLibName := DLLSSLName2; - end; SSLUtilHandle := LoadLibrary(PChar(DLLUtilName)); +{$IFNDEF LINUX} + if (SSLLibHandle = 0) then + SSLLibHandle := LoadLibrary(PChar(DLLSSLName2)); {$ENDIF} if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then begin - SslGetError := GetProcAddress(SSLLibHandle, PChar('SSL_get_error')); - SslLibraryInit := GetProcAddress(SSLLibHandle, PChar('SSL_library_init')); - SslLoadErrorStrings := GetProcAddress(SSLLibHandle, PChar('SSL_load_error_strings')); - SslCtxSetCipherList := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_cipher_list')); - SslCtxNew := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_new')); - SslCtxFree := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_free')); - SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd')); - SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method')); - SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_file')); - 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')); - SslConnect := GetProcAddress(SSLLibHandle, PChar('SSL_connect')); - SslShutdown := GetProcAddress(SSLLibHandle, PChar('SSL_shutdown')); - SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read')); - SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek')); - SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write')); - SslPending := GetProcAddress(SSLLibHandle, PChar('SSL_pending')); - SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate')); - SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version')); - SslCtxSetVerify := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_verify')); + _SslGetError := GetProcAddress(SSLLibHandle, PChar('SSL_get_error')); + _SslLibraryInit := GetProcAddress(SSLLibHandle, PChar('SSL_library_init')); + _SslLoadErrorStrings := GetProcAddress(SSLLibHandle, PChar('SSL_load_error_strings')); + _SslCtxSetCipherList := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_cipher_list')); + _SslCtxNew := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_new')); + _SslCtxFree := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_free')); + _SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd')); + _SslMethodV2 := GetProcAddress(SSLLibHandle, PChar('SSLv2_method')); + _SslMethodV3 := GetProcAddress(SSLLibHandle, PChar('SSLv3_method')); + _SslMethodTLSV1 := GetProcAddress(SSLLibHandle, PChar('TLSv1_method')); + _SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method')); + _SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_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')); + _SslConnect := GetProcAddress(SSLLibHandle, PChar('SSL_connect')); + _SslShutdown := GetProcAddress(SSLLibHandle, PChar('SSL_shutdown')); + _SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read')); + _SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek')); + _SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write')); + _SslPending := GetProcAddress(SSLLibHandle, PChar('SSL_pending')); + _SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate')); + _SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version')); + _SslCtxSetVerify := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_verify')); + _SslGetCurrentCipher := GetProcAddress(SSLLibHandle, PChar('SSL_get_current_cipher')); + _SslCipherGetName := GetProcAddress(SSLLibHandle, PChar('SSL_CIPHER_get_name')); + _SslCipherGetBits := GetProcAddress(SSLLibHandle, PChar('SSL_CIPHER_get_bits')); + _SslGetVerifyResult := GetProcAddress(SSLLibHandle, PChar('SSL_get_verify_result')); - SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free')); - SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline')); - SslX509GetSubjectName := GetProcAddress(SSLUtilHandle, PChar('X509_get_subject_name')); - SslX509GetIssuerName := GetProcAddress(SSLUtilHandle, PChar('X509_get_issuer_name')); - SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash')); - SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest')); - SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5')); - ErrerrorString := GetProcAddress(SSLUtilHandle, PChar('ERR_error_string')); - ErrGetError := GetProcAddress(SSLUtilHandle, PChar('ERR_get_error')); - ErrClearError := GetProcAddress(SSLUtilHandle, PChar('ERR_clear_error')); + _SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free')); + _SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline')); + _SslX509GetSubjectName := GetProcAddress(SSLUtilHandle, PChar('X509_get_subject_name')); + _SslX509GetIssuerName := GetProcAddress(SSLUtilHandle, PChar('X509_get_issuer_name')); + _SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash')); + _SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest')); + _SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5')); + _ErrErrorString := GetProcAddress(SSLUtilHandle, PChar('ERR_error_string')); + _ErrGetError := GetProcAddress(SSLUtilHandle, PChar('ERR_get_error')); + _ErrClearError := GetProcAddress(SSLUtilHandle, PChar('ERR_clear_error')); + _ErrFreeStrings := GetProcAddress(SSLUtilHandle, PChar('ERR_free_strings')); + _ErrRemoveState := GetProcAddress(SSLUtilHandle, PChar('ERR_remove_state')); + _EVPCleanup := GetProcAddress(SSLUtilHandle, PChar('EVP_cleanup')); + _CRYPTOcleanupAllExData := GetProcAddress(SSLUtilHandle, PChar('CRYPTO_cleanup_all_ex_data')); + _RandScreen := GetProcAddress(SSLUtilHandle, PChar('RAND_screen')); + _BioNew := GetProcAddress(SSLUtilHandle, PChar('BIO_new')); + _BioFreeAll := GetProcAddress(SSLUtilHandle, PChar('BIO_free_all')); + _BioSMem := GetProcAddress(SSLUtilHandle, PChar('BIO_s_mem')); + _BioCtrlPending := GetProcAddress(SSLUtilHandle, PChar('BIO_ctrl_pending')); + _BioRead := GetProcAddress(SSLUtilHandle, PChar('BIO_read')); + _BioWrite := GetProcAddress(SSLUtilHandle, PChar('BIO_write')); + _X509print := GetProcAddress(SSLUtilHandle, PChar('X509_print')); + SetLength(s, 1024); + x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s)); + SetLength(s, x); + SSLLibFile := s; + SetLength(s, 1024); + x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s)); + SetLength(s, x); + SSLUtilFile := s; Result := True; + //init library + if assigned(_SslLibraryInit) then + _SslLibraryInit; + if assigned(_SslLoadErrorStrings) then + _SslLoadErrorStrings; + if assigned(_RandScreen) then + _RandScreen; + SSLloaded := True; + end + else + begin + //load failed! + if SSLLibHandle <> 0 then + begin + FreeLibrary(SSLLibHandle); + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin + FreeLibrary(SSLUtilHandle); + SSLLibHandle := 0; + end; + Result := False; end; end - else Result := True; - if Result then - Inc(SSLCount); + else + //loaded before... + Result := true; finally SSLCS.Leave; end; @@ -231,28 +885,92 @@ function DestroySSLInterface: Boolean; begin SSLCS.Enter; try - Dec(SSLCount); - if SSLCount < 0 then - SSLCount := 0; - if SSLCount = 0 then + if IsSSLLoaded then begin - if SSLLibHandle <> 0 then - begin - FreeLibrary(SSLLibHandle); - SSLLibHandle := 0; - end; - if SSLUtilHandle <> 0 then - begin - FreeLibrary(SSLUtilHandle); - SSLLibHandle := 0; - end; + //deinit library + EVPCleanup; + CRYPTOcleanupAllExData; + ErrRemoveState(0); end; + SSLloaded := false; + if SSLLibHandle <> 0 then + begin + FreeLibrary(SSLLibHandle); + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin + FreeLibrary(SSLUtilHandle); + SSLLibHandle := 0; + end; + + _SslGetError := nil; + _SslLibraryInit := nil; + _SslLoadErrorStrings := nil; + _SslCtxSetCipherList := nil; + _SslCtxNew := nil; + _SslCtxFree := nil; + _SslSetFd := nil; + _SslMethodV2 := nil; + _SslMethodV3 := nil; + _SslMethodTLSV1 := nil; + _SslMethodV23 := nil; + _SslCtxUsePrivateKeyFile := nil; + _SslCtxUseCertificateChainFile := nil; + _SslCtxCheckPrivateKeyFile := nil; + _SslCtxSetDefaultPasswdCb := nil; + _SslCtxSetDefaultPasswdCbUserdata := nil; + _SslCtxLoadVerifyLocations := nil; + _SslNew := nil; + _SslFree := nil; + _SslAccept := nil; + _SslConnect := nil; + _SslShutdown := nil; + _SslRead := nil; + _SslPeek := nil; + _SslWrite := nil; + _SslPending := nil; + _SslGetPeerCertificate := nil; + _SslGetVersion := nil; + _SslCtxSetVerify := nil; + _SslGetCurrentCipher := nil; + _SslCipherGetName := nil; + _SslCipherGetBits := nil; + _SslGetVerifyResult := nil; + + _SslX509Free := nil; + _SslX509NameOneline := nil; + _SslX509GetSubjectName := nil; + _SslX509GetIssuerName := nil; + _SslX509NameHash := nil; + _SslX509Digest := nil; + _SslEvpMd5 := nil; + _ErrErrorString := nil; + _ErrGetError := nil; + _ErrClearError := nil; + _ErrFreeStrings := nil; + _ErrRemoveState := nil; + _EVPCleanup := nil; + _CRYPTOcleanupAllExData := nil; + _RandScreen := nil; + _BioNew := nil; + _BioFreeAll := nil; + _BioSMem := nil; + _BioCtrlPending := nil; + _BioRead := nil; + _BioWrite := nil; + _X509print := nil; finally SSLCS.Leave; end; Result := True; end; +function IsSSLloaded: Boolean; +begin + Result := SSLLoaded; +end; + initialization begin SSLCS:= TCriticalSection.Create; @@ -260,6 +978,7 @@ end; finalization begin + DestroySSLInterface; SSLCS.Free; end; diff --git a/synautil.pas b/synautil.pas index d409b6a..8f55cd0 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.005.001 | +| Project : Ararat Synapse | 004.000.002 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| @@ -44,10 +44,14 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} {$Q-} {$R-} +{$H+} -unit SynaUtil; +unit synautil; interface @@ -78,11 +82,14 @@ function DecodeInt(const Value: string; Index: Integer): Word; function IsIP(const Value: string): Boolean; function IsIP6(const Value: string): Boolean; function IPToID(Host: string): string; +function DumpStr(const Buffer: string): string; +function DumpExStr(const Buffer: string): string; procedure Dump(const Buffer, DumpFile: string); procedure DumpEx(const Buffer, DumpFile: string); function SeparateLeft(const Value, Delimiter: string): string; function SeparateRight(const Value, Delimiter: string): string; function GetParameter(const Value, Parameter: string): string; +procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); procedure ParseParameters(Value: string; const Parameters: TStrings); function IndexByBegin(Value: string; const List: TStrings): integer; function GetEmailAddr(const Value: string): string; @@ -96,11 +103,15 @@ function ReplaceString(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; +function FetchEx(var Value: string; const Delimiter, Quotation: string): string; function IsBinaryString(const Value: string): Boolean; function PosCRLF(const Value: string; var Terminator: string): integer; Procedure StringsTrim(const value: TStrings); function PosFrom(const SubStr, Value: String; From: integer): integer; function IncPoint(const p: pointer; Value: integer): pointer; +function GetBetween(const PairBegin, PairEnd, Value: string): string; +function CountOfChar(const Value: string; Chr: char): integer; +function UnquoteStr(const Value: string; Quote: Char): string; implementation @@ -121,8 +132,13 @@ var t: TTime_T; UT: TUnixTime; begin +{$IFNDEF FPC} __time(@T); localtime_r(@T, UT); +{$ELSE} + __time(T); + localtime_r(T, UT); +{$ENDIF} Result := ut.__tm_gmtoff div 60; {$ELSE} var @@ -430,6 +446,9 @@ begin day := 1; Result := Result + Encodedate(year, month, day); zone := zone - TimeZoneBias; + x := zone div 1440; + Result := Result - x; + zone := zone mod 1440; t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); if zone < 0 then t := 0 - t; @@ -440,17 +459,36 @@ end; function GetUTTime: TDateTime; {$IFNDEF LINUX} +{$IFNDEF FPC} var st: TSystemTime; begin - GetSystemTime(st); - result:=SystemTimeToDateTime(st); + GetSystemTime(st); + result := SystemTimeToDateTime(st); +{$ELSE} +var + st: SysUtils.TSystemTime; + stw: Windows.TSystemTime; +begin + GetSystemTime(stw); + st.Year := stw.wYear; + st.Month := stw.wMonth; + st.Day := stw.wDay; + st.Hour := stw.wHour; + st.Minute := stw.wMinute; + st.Second := stw.wSecond; + st.Millisecond := stw.wMilliseconds; + result := SystemTimeToDateTime(st); +{$ENDIF} {$ELSE} var TV: TTimeVal; + TZ: Ttimezone; begin - gettimeofday(TV, nil); - Result:=UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; + TZ.tz_minuteswest := 0; + TZ.tz_dsttime := 0; + gettimeofday(TV, TZ); + Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; {$ENDIF} end; @@ -458,11 +496,27 @@ end; function SetUTTime(Newdt: TDateTime): Boolean; {$IFNDEF LINUX} +{$IFNDEF FPC} var st: TSystemTime; begin - DateTimeToSystemTime(newdt,st); - Result:=SetSystemTime(st); + DateTimeToSystemTime(newdt,st); + Result := SetSystemTime(st); +{$ELSE} +var + st: SysUtils.TSystemTime; + stw: Windows.TSystemTime; +begin + DateTimeToSystemTime(newdt,st); + stw.wYear := st.Year; + stw.wMonth := st.Month; + stw.wDay := st.Day; + stw.wHour := st.Hour; + stw.wMinute := st.Minute; + stw.wSecond := st.Second; + stw.wMilliseconds := st.Millisecond; + Result := SetSystemTime(stw); +{$ENDIF} {$ELSE} var TV: TTimeVal; @@ -470,6 +524,8 @@ var TZ: Ttimezone; begin Result := false; + TZ.tz_minuteswest := 0; + TZ.tz_dsttime := 0; gettimeofday(TV, TZ); d := (newdt - UnixDateDelta) * 86400; TV.tv_sec := trunc(d); @@ -642,21 +698,45 @@ end; {==============================================================================} -procedure Dump(const Buffer, DumpFile: string); +function DumpStr(const Buffer: string): string; var n: Integer; - s: string; +begin + Result := ''; + for n := 1 to Length(Buffer) do + Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); +end; + +{==============================================================================} + +function DumpExStr(const Buffer: string): string; +var + n: Integer; + x: Byte; +begin + Result := ''; + for n := 1 to Length(Buffer) do + begin + x := Ord(Buffer[n]); + if x in [65..90, 97..122] then + Result := Result + ' +''' + char(x) + '''' + else + Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); + end; +end; + +{==============================================================================} + +procedure Dump(const Buffer, DumpFile: string); +var f: Text; begin - s := ''; - for n := 1 to Length(Buffer) do - s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2); AssignFile(f, DumpFile); if FileExists(DumpFile) then DeleteFile(PChar(DumpFile)); Rewrite(f); try - Writeln(f, s); + Writeln(f, DumpStr(Buffer)); finally CloseFile(f); end; @@ -666,26 +746,14 @@ end; procedure DumpEx(const Buffer, DumpFile: string); var - n: Integer; - x: Byte; - s: string; f: Text; begin - s := ''; - for n := 1 to Length(Buffer) do - begin - x := Ord(Buffer[n]); - if x in [65..90, 97..122] then - s := s + ' +''' + char(x) + '''' - else - s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2); - end; AssignFile(f, DumpFile); if FileExists(DumpFile) then DeleteFile(PChar(DumpFile)); Rewrite(f); try - Writeln(f, s); + Writeln(f, DumpExStr(Buffer)); finally CloseFile(f); end; @@ -720,7 +788,7 @@ end; function GetParameter(const Value, Parameter: string): string; var - x, x1: Integer; + x: Integer; s: string; begin x := Pos(UpperCase(Parameter), UpperCase(Value)); @@ -730,43 +798,39 @@ begin s := Copy(Value, x + Length(Parameter), Length(Value) - (x + Length(Parameter)) + 1); s := Trim(s); - x1 := Length(s); if Length(s) > 1 then begin - if s[1] = '"' then - begin - s := Copy(s, 2, Length(s) - 1); - x := Pos('"', s); - if x > 0 then - x1 := x - 1; - end - else - begin - x := Pos(' ', s); - if x > 0 then - x1 := x - 1; - end; + x := pos(';', s); + if x > 0 then + s := Copy(s, 1, x - 1); + Result := UnquoteStr(s, '"'); end; - Result := Copy(s, 1, x1); end; end; {==============================================================================} -procedure ParseParameters(Value: string; const Parameters: TStrings); +procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); var s: string; begin Parameters.Clear; while Value <> '' do begin - s := Fetch(Value, ';'); + s := Fetch(Value, Delimiter); Parameters.Add(s); end; end; {==============================================================================} +procedure ParseParameters(Value: string; const Parameters: TStrings); +begin + ParseParametersEx(Value, ';', Parameters); +end; + +{==============================================================================} + function IndexByBegin(Value: string; const List: TStrings): integer; var n: integer; @@ -1033,6 +1097,40 @@ 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 + begin + if b then + begin + if Pos(Quotation, Value) = 1 then + b := False; + Result := Result + Value[1]; + Delete(Value, 1, 1); + end + else + begin + if Pos(Delimiter, Value) = 1 then + begin + Delete(Value, 1, Length(delimiter)); + break; + end; + b := Pos(Quotation, Value) = 1; + Result := Result + Value[1]; + Delete(Value, 1, 1); + end; + end; + Result := Trim(Result); +end; + +{==============================================================================} + function IsBinaryString(const Value: string): Boolean; var n: integer; @@ -1132,4 +1230,53 @@ end; {==============================================================================} +function GetBetween(const PairBegin, PairEnd, Value: string): string; +var + n: integer; + x: integer; + s: string; +begin + Result := ''; + s := SeparateRight(Value, PairBegin); + x := 1; + for n := 1 to Length(s) do + begin + if s[n] = PairBegin then + Inc(x); + if s[n] = PairEnd then + begin + Dec(x); + if x <= 0 then + Break; + end; + Result := Result + s[n]; + end; +end; + +{==============================================================================} + +function CountOfChar(const Value: string; Chr: char): integer; +var + n: integer; +begin + Result := 0; + for n := 1 to Length(Value) do + if Value[n] = chr then + Inc(Result); +end; + +{==============================================================================} + +function UnquoteStr(const Value: string; Quote: Char): string; +var + LText: PChar; +begin + LText := PChar(Value); + Result := AnsiExtractQuotedStr(LText, Quote); + if Result = '' then + Result := Value; +end; + +{==============================================================================} + end. diff --git a/synsock.pas b/synsock.pas index 93898a6..55b4803 100644 --- a/synsock.pas +++ b/synsock.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.001.003 | +| Project : Ararat Synapse | 004.001.000 | |==============================================================================| | Content: Socket Independent Platform Layer | |==============================================================================| @@ -56,12 +56,16 @@ On Linux is level 2.2 always used! //{$DEFINE FORCEOLDAPI} {Note about define FORCEOLDAPI: If you activate this compiler directive, then is allways used old socket API -for name resolution. If you leave this directive inactive, then when new API +for name resolution. If you leave this directive inactive, then the new API is used, when running system allows it. For IPv6 support you must have new API! } +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} {$IFDEF VER125} {$DEFINE BCB} {$ENDIF} @@ -234,6 +238,9 @@ interface uses SyncObjs, SysUtils, {$IFDEF LINUX} + {$IFDEF FPC} + synafpc, + {$ENDIF} Libc; {$ELSE} Windows; @@ -574,6 +581,15 @@ Const MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $4; + NI_NUMERICHOST = $1; + NI_NAMEREQD = $8; + NI_NUMERICSERV = $2; + NI_DGRAM = $10; + {=============================================================================} {$ELSE} Const @@ -654,6 +670,15 @@ Const MSG_NOSIGNAL = 0; + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $1; + NI_NUMERICHOST = $2; + NI_NAMEREQD = $4; + NI_NUMERICSERV = $8; + NI_DGRAM = $10; + {$ENDIF} {=============================================================================} @@ -721,15 +746,6 @@ const AI_CANONNAME = $2; // Return canonical name in first ai_canonname. AI_NUMERICHOST = $4; // Nodename must be a numeric address string. - // getnameinfo constants - NI_MAXHOST = 1025; - NI_MAXSERV = 32; - NI_NOFQDN = $1; - NI_NUMERICHOST = $2; - NI_NAMEREQD = $4; - NI_NUMERICSERV = $8; - NI_DGRAM = $10; - type { Structure used for manipulating linger option. } PLinger = ^TLinger; @@ -971,87 +987,133 @@ const {=============================================================================} var WSAStartup: function(wVersionRequired: Word; var WSData: TWSAData): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} WSACleanup: function: Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} WSAGetLastError: function: Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetServByName: function(name, proto: PChar): PServEnt - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetServByPort: function(port: Integer; proto: PChar): PServEnt - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetProtoByName: function(name: PChar): PProtoEnt - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetProtoByNumber: function(proto: Integer): PProtoEnt - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetHostByName: function(name: PChar): PHostEnt - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetHostByAddr: function(addr: Pointer; len, Struc: Integer): PHostEnt - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetHostName: function(name: PChar; len: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Shutdown: function(s: TSocket; how: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} SetSockOpt: function(s: TSocket; level, optname: Integer; optval: PChar; - optlen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + optlen: Integer): Integer + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetSockOpt: function(s: TSocket; level, optname: Integer; optval: PChar; - var optlen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - SendTo: function(s: TSocket; var Buf; len, flags: Integer; addrto: PSockAddr; - tolen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - Send: function(s: TSocket; var Buf; len, flags: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + var optlen: Integer): Integer + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} + SendTo: function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} + Send: function(s: TSocket; const Buf; len, flags: Integer): Integer + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Recv: function(s: TSocket; var Buf; len, flags: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} RecvFrom: function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; - var fromlen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + var fromlen: Integer): Integer + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} ntohs: function(netshort: u_short): u_short - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} ntohl: function(netlong: u_long): u_long - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Listen: function(s: TSocket; backlog: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} IoctlSocket: function(s: TSocket; cmd: DWORD; var arg: u_long): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Inet_ntoa: function(inaddr: TInAddr): PChar - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Inet_addr: function(cp: PChar): u_long - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} htons: function(hostshort: u_short): u_short - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} htonl: function(hostlong: u_long): u_long - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetSockName: function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetPeerName: function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Connect: function(s: TSocket; name: PSockAddr; namelen: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} CloseSocket: function(s: TSocket): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Bind: function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Accept: function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Socket: function(af, Struc, Protocol: Integer): TSocket - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} Select: function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + timeout: PTimeVal): Longint + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetAddrInfo: function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo; var Addrinfo: PAddrInfo): integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} FreeAddrInfo: procedure(ai: PAddrInfo) - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} GetNameInfo: function( addr: PSockAddr; namelen: Integer; host: PChar; hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer - {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; + {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} {$IFNDEF LINUX} - __WSAFDIsSet: function (s: TSocket; var FDSet: TFDSet): Bool stdcall = nil; + __WSAFDIsSet: function (s: TSocket; var FDSet: TFDSet): Bool + {$IFNDEF FPC}stdcall = nil; + {$ELSE}= nil; stdcall;{$ENDIF} + WSAIoctl: function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; - lpCompletionRoutine: pointer): u_int stdcall = nil; + lpCompletionRoutine: pointer): u_int + {$IFNDEF FPC}stdcall = nil; + {$ELSE}= nil; stdcall;{$ENDIF} {$ENDIF} {$IFDEF LINUX} @@ -1061,10 +1123,24 @@ function LSWSAGetLastError: Integer; cdecl; {$ENDIF} var - SynSockCS: TCriticalSection; + SynSockCS: SyncObjs.TCriticalSection; SockEnhancedApi: Boolean; SockWship6Api: Boolean; +type + TVarSin = packed record + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + const {$IFDEF LINUX} DLLStackName = 'libc.so.6'; @@ -1132,7 +1208,11 @@ end; {=============================================================================} {$IFDEF LINUX} var +{$IFNDEF FPC} errno_loc: function: PInteger cdecl = nil; +{$ELSE} + errno_loc: function: PInteger = nil; cdecl; +{$ENDIF} function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; begin @@ -1154,8 +1234,11 @@ begin end; function LSWSAGetLastError: Integer; +var + p: PInteger; begin - Result := errno_loc^; + p := errno_loc; + Result := p^; end; function __FDELT(Socket: TSocket): Integer; @@ -1237,6 +1320,19 @@ end; {=============================================================================} +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; +{=============================================================================} + function InitSocketInterface(stack: string): Boolean; begin Result := False; @@ -1251,10 +1347,8 @@ begin SockWship6Api := False; {$IFDEF LINUX} Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); - LibHandle := HMODULE(dlopen(PChar(Stack), RTLD_GLOBAL)); -{$ELSE} - LibHandle := LoadLibrary(PChar(Stack)); {$ENDIF} + LibHandle := LoadLibrary(PChar(Stack)); if LibHandle <> 0 then begin {$IFDEF LINUX} @@ -1362,7 +1456,7 @@ end; initialization begin - SynSockCS:= TCriticalSection.Create; + SynSockCS := SyncObjs.TCriticalSection.Create; SET_IN6_IF_ADDR_ANY (@in6addr_any); SET_LOOPBACK_ADDR6 (@in6addr_loopback); end; diff --git a/tlntsend.pas b/tlntsend.pas index 74fc8de..196c583 100644 --- a/tlntsend.pas +++ b/tlntsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.001 | +| Project : Ararat Synapse | 001.001.003 | |==============================================================================| | Content: TELNET client | |==============================================================================| @@ -44,13 +44,18 @@ //RFC-854 -unit TlntSend; +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit tlntsend; interface uses SysUtils, Classes, - blcksock, SynaUtil; + blcksock, synautil; const cTelnetProtocol = 'telnet';