diff --git a/blcksock.pas b/blcksock.pas index 4354752..277b6f8 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 009.001.003 | +| Project : Ararat Synapse | 009.004.001 | |==============================================================================| | Content: Library base | |==============================================================================| -| Copyright (c)1999-2006, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)1999-2006. | +| Portions created by Lukas Gebauer are Copyright (c)1999-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -99,7 +99,7 @@ uses const - SynapseRelease = '37'; + SynapseRelease = '38'; cLocalhost = '127.0.0.1'; cAnyHost = '0.0.0.0'; @@ -188,6 +188,15 @@ type THookMonitor = procedure(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer) of object; + {:This procedural type is used for hook OnAfterConnect. By this hook you can + insert your code after TCP socket has been sucessfully connected.} + THookAfterConnect = procedure(Sender: TObject) of object; + + {:This procedural type is used for hook OnHeartbeat. By this hook you can + call your code repeately during long socket operations. + You must enable heartbeats by @Link(HeartbeatRate) property!} + THookHeartbeat = procedure(Sender: TObject) of object; + {:Specify family of socket.} TSocketFamily = ( {:Default mode. Socket family is defined by target address for connection. @@ -254,6 +263,7 @@ type FOnReadFilter: THookDataFilter; FOnCreateSocket: THookCreateSocket; FOnMonitor: THookMonitor; + FOnHeartbeat: THookHeartbeat; FLocalSin: TVarSin; FRemoteSin: TVarSin; FTag: integer; @@ -282,6 +292,8 @@ type FSendCounter: Integer; FSendMaxChunk: Integer; FStopFlag: Boolean; + FNonblockSendTimeout: Integer; + FHeartbeatRate: integer; function GetSizeRecvBuffer: Integer; procedure SetSizeRecvBuffer(Size: Integer); function GetSizeSendBuffer: Integer; @@ -308,10 +320,12 @@ type procedure DoReadFilter(Buffer: TMemory; var Len: Integer); procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); procedure DoCreateSocket; + procedure DoHeartbeat; procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); procedure SetBandwidth(Value: Integer); function TestStopFlag: Boolean; procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual; + function InternalCanRead(Timeout: Integer): Boolean; virtual; public constructor Create; @@ -537,10 +551,13 @@ type {:Actualize values in @link(LocalSin) and @link(RemoteSin).} procedure GetSins; + {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.} + procedure ResetLastError; + {:If you "manually" call Socket API functions, forward their return code as parameter to this function, which evaluates it, eventually calls GetLastError and found error code returns and stores to @link(LastError).} - function SockCheck(SockResult: Integer): Integer; + function SockCheck(SockResult: Integer): Integer; virtual; {:If @link(LastError) contains some error code and @link(RaiseExcept) property is @true, raise adequate exception.} @@ -590,7 +607,8 @@ type data maybe forever. This function is need only on special cases, when you need use - @link(RecvBuffer) function directly!} + @link(RecvBuffer) function directly! read functioms what have timeout as + calling parameter, calling this function internally.} function CanRead(Timeout: Integer): Boolean; virtual; {:Same as @link(CanRead), but additionally return @TRUE if is some data in @@ -714,6 +732,9 @@ type You may call it without created object!} class function GetErrorDesc(ErrorCode: Integer): string; + {:Return descriptive string for @link(LastError).} + function GetErrorDescEx: string; virtual; + {:this value is for free use.} property Tag: Integer read FTag write FTag; @@ -770,6 +791,9 @@ type use this property for soft abort of communication.} property StopFlag: Boolean read FStopFlag Write FStopFlag; + {:Timeout for data sending by non-blocking socket mode.} + property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout; + {:This event is called by various reasons. It is good for monitoring socket, create gauges for data transfers, etc.} property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; @@ -785,6 +809,18 @@ type {:This event is good for monitoring content of readed or writed datas.} property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor; + + {:This event is good for calling your code during long socket operations. + (Example, for refresing UI if class in not called within the thread.) + Rate of heartbeats can be modified by @link(HeartbeatRate) property.} + property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat; + + {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing. + Default value 0 disabling heartbeats! Value is in milliseconds. + Real rate can be higher or smaller then this value, because it depending + on real socket operations too! + Note: Each heartbeat slowing socket processing.} + property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate; end; {:@abstract(Support for SOCKS4 and SOCKS5 proxy) @@ -865,6 +901,7 @@ type (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.} TTCPBlockSocket = class(TSocksBlockSocket) protected + FOnAfterConnect: THookAfterConnect; FSSL: TCustomSSL; FHTTPTunnelIP: string; FHTTPTunnelPort: string; @@ -876,6 +913,7 @@ type FHTTPTunnelTimeout: integer; procedure SocksDoConnect(IP, Port: string); procedure HTTPTunnelDoConnect(IP, Port: string); + procedure DoAfterConnect; public {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation (see @link(SSLImplementation))} @@ -885,6 +923,10 @@ type constructor CreateWithSSL(SSLPlugin: TSSLClass); destructor Destroy; override; + {:Return descriptive string for @link(LastError). On case of error + in SSL/TLS subsystem, it returns right error description.} + function GetErrorDescEx: string; override; + {:See @link(TBlockSocket.CloseSocket)} procedure CloseSocket; override; @@ -994,6 +1036,9 @@ type {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.} property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout; + + {:This event is called after sucessful TCP socket connection.} + property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect; end; {:@abstract(Datagram based communication) @@ -1410,6 +1455,8 @@ begin FSendCounter := 0; FSendMaxChunk := c64k; FStopFlag := False; + FNonblockSendTimeout := 15000; + FHeartbeatRate := 0; {$IFNDEF ONCEWINSOCK} if Stub = '' then Stub := DLLStackName; @@ -1615,7 +1662,7 @@ var f: TSocketFamily; begin DoStatus(HR_ResolvingBegin, IP + ':' + Port); - FLastError := 0; + ResetLastError; //if socket exists, then use their type, else use users selection f := SF_Any; if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then @@ -1648,7 +1695,7 @@ var sin: TVarSin; begin //dummy for SF_Any Family mode - FLastError := 0; + ResetLastError; if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then begin {$IFDEF CIL} @@ -1671,7 +1718,7 @@ procedure TBlockSocket.CreateSocketByName(const Value: String); var sin: TVarSin; begin - FLastError := 0; + ResetLastError; if FSocket = INVALID_SOCKET then begin SetSin(sin, value, '0'); @@ -1685,7 +1732,7 @@ begin FStopFlag := False; FRecvCounter := 0; FSendCounter := 0; - FLastError := 0; + ResetLastError; if FSocket = INVALID_SOCKET then begin FBuffer := ''; @@ -1728,7 +1775,6 @@ begin end; FDelayedOptions.Clear; FFamily := FFamilySave; - FLastError := 0; DoStatus(HR_SocketClose, ''); end; @@ -1736,7 +1782,7 @@ procedure TBlockSocket.Bind(IP, Port: string); var Sin: TVarSin; begin - FLastError := 0; + ResetLastError; if (FSocket <> INVALID_SOCKET) or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then begin @@ -1801,7 +1847,10 @@ procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: var x: LongWord; y: LongWord; + n: integer; begin + if FStopFlag then + exit; if MaxB > 0 then begin y := GetTick; @@ -1811,7 +1860,12 @@ begin if x > 0 then begin DoStatus(HR_Wait, IntToStr(x)); - sleep(x); + sleep(x mod 250); + for n := 1 to x div 250 do + if FStopFlag then + Break + else + sleep(250); end; end; Next := GetTick + Trunc((Length / MaxB) * 1000); @@ -1820,6 +1874,7 @@ end; function TBlockSocket.TestStopFlag: Boolean; begin + DoHeartbeat; Result := FStopFlag; if Result then begin @@ -1856,10 +1911,19 @@ begin begin LimitBandwidth(y, FMaxSendBandwidth, FNextsend); p := IncPoint(Buffer, x); -// r := synsock.Send(FSocket, p^, y, MSG_NOSIGNAL); r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); SockCheck(r); - if Flasterror <> 0 then + if FLastError = WSAEWOULDBLOCK then + begin + if CanWrite(FNonblockSendTimeout) then + begin + r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); + SockCheck(r); + end + else + FLastError := WSAETIMEDOUT; + end; + if FLastError <> 0 then Break; Inc(x, r); Inc(Result, r); @@ -2031,7 +2095,7 @@ var b: TMemory; {$ENDIF} begin - FLastError := 0; + ResetLastError; Result := 0; if Len > 0 then begin @@ -2109,7 +2173,7 @@ var {$ENDIF} begin Result := ''; - FLastError := 0; + ResetLastError; if FBuffer <> '' then begin Result := FBuffer; @@ -2184,7 +2248,7 @@ end; function TBlockSocket.RecvByte(Timeout: Integer): Byte; begin Result := 0; - FLastError := 0; + ResetLastError; if FBuffer = '' then FBuffer := RecvPacket(Timeout); if (FLastError = 0) and (FBuffer <> '') then @@ -2215,7 +2279,7 @@ var tl: integer; ti: LongWord; begin - FLastError := 0; + ResetLastError; Result := ''; l := Length(Terminator); if l = 0 then @@ -2393,24 +2457,28 @@ begin {$ENDIF} end; +procedure TBlockSocket.ResetLastError; +begin + FLastError := 0; + FLastErrorDesc := ''; +end; + function TBlockSocket.SockCheck(SockResult: Integer): Integer; begin - FLastErrorDesc := ''; + ResetLastError; if SockResult = integer(SOCKET_ERROR) then begin - Result := synsock.WSAGetLastError; - FLastErrorDesc := GetErrorDesc(Result); - end - else - Result := 0; - FLastError := Result; + FLastError := synsock.WSAGetLastError; + FLastErrorDesc := GetErrorDescEx; + end; + Result := FLastError; end; procedure TBlockSocket.ExceptCheck; var e: ESynapseError; begin - FLastErrorDesc := GetErrorDesc(FLastError); + FLastErrorDesc := GetErrorDescEx; if (LastError <> 0) and (LastError <> WSAEINPROGRESS) and (LastError <> WSAEWOULDBLOCK) then begin @@ -2419,8 +2487,6 @@ begin begin e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s', [FLastError, FLastErrorDesc])); -// e := ESynapseError.CreateFmt('Synapse TCP/IP Socket error %d: %s', -// [FLastError, FLastErrorDesc]); e.ErrorCode := FLastError; e.ErrorMessage := FLastErrorDesc; raise e; @@ -2460,7 +2526,7 @@ begin except on exception do; end; - FLastError := 0; + ResetLastError; end; procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); @@ -2539,7 +2605,7 @@ begin Result := GetSinPort(FRemoteSin); end; -function TBlockSocket.CanRead(Timeout: Integer): Boolean; +function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean; {$IFDEF CIL} begin Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead); @@ -2562,6 +2628,38 @@ begin x := 0; Result := x > 0; {$ENDIF} +end; + +function TBlockSocket.CanRead(Timeout: Integer): Boolean; +var + ti, tr: Integer; + n: integer; +begin + if (FHeartbeatRate <> 0) and (Timeout <> -1) then + begin + ti := Timeout div FHeartbeatRate; + tr := Timeout mod FHeartbeatRate; + end + else + begin + ti := 0; + tr := Timeout; + end; + Result := InternalCanRead(tr); + if not Result then + for n := 0 to ti do + begin + DoHeartbeat; + if FStopFlag then + begin + Result := False; + FStopFlag := False; + Break; + end; + Result := InternalCanRead(FHeartbeatRate); + if Result then + break; + end; ExceptCheck; if Result then DoStatus(HR_CanRead, ''); @@ -2878,6 +2976,19 @@ begin end; end; +procedure TBlockSocket.DoHeartbeat; +begin + if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then + begin + OnHeartbeat(Self); + end; +end; + +function TBlockSocket.GetErrorDescEx: string; +begin + Result := GetErrorDesc(FLastError); +end; + class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; begin {$IFDEF CIL} @@ -3399,7 +3510,7 @@ begin end else begin - Multicast.imr_multiaddr.S_addr := strtoip(MCastIP); + Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); Multicast.imr_interface.S_addr := INADDR_ANY; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, pchar(@Multicast), SizeOf(Multicast))); @@ -3425,7 +3536,7 @@ begin end else begin - Multicast.imr_multiaddr.S_addr := strtoip(MCastIP); + Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); Multicast.imr_interface.S_addr := INADDR_ANY; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, pchar(@Multicast), SizeOf(Multicast))); @@ -3503,11 +3614,20 @@ begin FSSL.Free; end; +function TTCPBlockSocket.GetErrorDescEx: string; +begin + Result := inherited GetErrorDescEx; + if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then + begin + Result := self.SSL.LastErrorDesc; + end; +end; + procedure TTCPBlockSocket.CloseSocket; begin if FSSL.SSLEnabled then FSSL.Shutdown; - if FSocket <> INVALID_SOCKET then + if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then begin Synsock.Shutdown(FSocket, 1); Purge; @@ -3515,6 +3635,14 @@ begin inherited CloseSocket; end; +procedure TTCPBlockSocket.DoAfterConnect; +begin + if assigned(OnAfterConnect) then + begin + OnAfterConnect(Self); + end; +end; + function TTCPBlockSocket.WaitingData: Integer; begin Result := 0; @@ -3587,6 +3715,8 @@ begin HTTPTunnelDoConnect(IP, Port) else inherited Connect(IP, Port); + if FLasterror = 0 then + DoAfterConnect; end; procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); @@ -3645,7 +3775,7 @@ end; procedure TTCPBlockSocket.SSLDoConnect; begin - FLastError := 0; + ResetLastError; if not FSSL.Connect then FLastError := WSASYSNOTREADY; ExceptCheck; @@ -3653,7 +3783,7 @@ end; procedure TTCPBlockSocket.SSLDoShutdown; begin - FLastError := 0; + ResetLastError; FSSL.BiShutdown; end; @@ -3702,7 +3832,8 @@ begin Result := 0; if TestStopFlag then Exit; - FLastError := 0; + ResetLastError; + LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv); Result := FSSL.RecvBuffer(Buffer, Len); if FSSL.LastError <> 0 then FLastError := WSASYSNOTREADY; @@ -3729,7 +3860,7 @@ begin Result := 0; if TestStopFlag then Exit; - FLastError := 0; + ResetLastError; DoMonitor(True, Buffer, Length); {$IFDEF CIL} Result := FSSL.SendBuffer(Buffer, Length); @@ -3771,7 +3902,7 @@ end; function TTCPBlockSocket.SSLAcceptConnection: Boolean; begin - FLastError := 0; + ResetLastError; if not FSSL.Accept then FLastError := WSASYSNOTREADY; ExceptCheck; @@ -3881,7 +4012,7 @@ end; procedure TCustomSSL.ReturnError; begin FLastError := -1; - FLastErrorDesc := 'SLL is not implemented!'; + FLastErrorDesc := 'SSL/TLS support is not compiled!'; end; function TCustomSSL.LibVersion: String; diff --git a/dnssend.pas b/dnssend.pas index 16f0cb9..f7684ce 100644 --- a/dnssend.pas +++ b/dnssend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.007.003 | +| Project : Ararat Synapse | 002.007.004 | |==============================================================================| | Content: DNS client | |==============================================================================| -| Copyright (c)1999-2004, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -63,7 +63,7 @@ uses blcksock, synautil, synaip, synsock; const - cDnsProtocol = 'domain'; + cDnsProtocol = '53'; QTYPE_A = 1; QTYPE_NS = 2; diff --git a/ftpsend.pas b/ftpsend.pas index 2ec6f7f..b92ffa9 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.004.008 | +| Project : Ararat Synapse | 003.005.000 | |==============================================================================| | Content: FTP client | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -62,8 +62,8 @@ uses blcksock, synautil, synaip, synsock; const - cFtpProtocol = 'ftp'; - cFtpDataProtocol = 'ftp-data'; + cFtpProtocol = '21'; + cFtpDataProtocol = '20'; {:Terminating value for TLogonActions} FTP_OK = 255; @@ -314,6 +314,9 @@ type function ChangeWorkingDir(const Directory: string): Boolean; virtual; {:walk to upper directory on FTP server.} + function ChangeToParentDir: Boolean; virtual; + + {:walk to root directory on FTP server. (May not work with all servers properly!)} function ChangeToRootDir: Boolean; virtual; {:Delete Directory on FTP server.} @@ -872,7 +875,7 @@ begin FDSock.Bind(FSock.GetLocalSinIP, s); if FDSock.LastError <> 0 then Exit; - FDSock.SetLinger(True, 10); + FDSock.SetLinger(True, 10000); FDSock.Listen; FDSock.GetSins; FDataIP := FDSock.GetLocalSinIP; @@ -1143,11 +1146,16 @@ begin Result := (FTPCommand('CWD ' + Directory) div 100) = 2; end; -function TFTPSend.ChangeToRootDir: Boolean; +function TFTPSend.ChangeToParentDir: Boolean; begin Result := (FTPCommand('CDUP') div 100) = 2; end; +function TFTPSend.ChangeToRootDir: Boolean; +begin + Result := ChangeWorkingDir('/'); +end; + function TFTPSend.DeleteDir(const Directory: string): Boolean; begin Result := (FTPCommand('RMD ' + Directory) div 100) = 2; diff --git a/httpsend.pas b/httpsend.pas index b23812d..ac1019e 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.010.005 | +| Project : Ararat Synapse | 003.011.003 | |==============================================================================| | Content: HTTP client | |==============================================================================| -| Copyright (c)1999-2006, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2006. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -93,6 +93,7 @@ type FUploadSize: integer; FRangeStart: integer; FRangeEnd: integer; + FAddPortNumberToHost: Boolean; function ReadUnknown: Boolean; function ReadIdentity(Size: Integer): Boolean; function ReadChunked: Boolean; @@ -203,6 +204,10 @@ type property UploadSize: integer read FUploadSize; {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; + + {:To have possibility to switch off port number in 'Host:' HTTP header, by + default @TRUE. Some buggy servers not like port informations in this header.} + property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost; end; {:A very usefull function, and example of use can be found in the THTTPSend @@ -272,6 +277,7 @@ begin FUserAgent := 'Mozilla/4.0 (compatible; Synapse)'; FDownloadSize := 0; FUploadSize := 0; + FAddPortNumberToHost := true; Clear; end; @@ -407,7 +413,7 @@ begin if FUserAgent <> '' then FHeaders.Insert(0, 'User-Agent: ' + FUserAgent); { setting Ranges } - if FRangeStart > 0 then + if (FRangeStart > 0) or (FRangeEnd > 0) then begin if FRangeEnd >= FRangeStart then FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd)) @@ -437,7 +443,7 @@ begin s := '[' + Host + ']' else s := Host; - if Port<>'80' then + if FAddPortNumberToHost and (Port <> '80') then FHeaders.Insert(0, 'Host: ' + s + ':' + Port) else FHeaders.Insert(0, 'Host: ' + s); @@ -465,7 +471,6 @@ begin { connect } if not InternalConnect(UpperCase(Prot) = 'HTTPS') then begin - FSock.CloseSocket; FAliveHost := ''; FAlivePort := ''; Exit; @@ -538,18 +543,20 @@ begin if s <> '' then Break; until FSock.LastError <> 0; - if Pos('HTTP/', UpperCase(s)) = 1 then - begin - FHeaders.Add(s); - DecodeStatus(s); - end - else - begin - { old HTTP 0.9 and some buggy servers not send result } - s := s + CRLF; - WriteStrToStream(FDocument, s); - FResultCode := 0; - end; + repeat + if Pos('HTTP/', UpperCase(s)) = 1 then + begin + FHeaders.Add(s); + DecodeStatus(s); + end + else + begin + { old HTTP 0.9 and some buggy servers not send result } + s := s + CRLF; + WriteStrToStream(FDocument, s); + FResultCode := 0; + end; + until (FSock.LastError <> 0) or (FResultCode <> 100); end else FHeaders.Add(Status100Error); @@ -566,7 +573,7 @@ begin if Pos('CONTENT-LENGTH:', su) = 1 then begin Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1); - if Size <> -1 then + if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then FTransferEncoding := TE_IDENTITY; end; if Pos('CONTENT-TYPE:', su) = 1 then @@ -612,12 +619,17 @@ function THTTPSend.ReadUnknown: Boolean; var s: string; begin + Result := false; repeat s := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then WriteStrToStream(FDocument, s); until FSock.LastError <> 0; - Result := FSock.LastError = WSAECONNRESET; + if FSock.LastError = WSAECONNRESET then + begin + Result := true; + FSock.ResetLastError; + end; end; function THTTPSend.ReadIdentity(Size: Integer): Boolean; @@ -719,6 +731,7 @@ begin HTTP.Document.CopyFrom(Data, 0); HTTP.MimeType := 'Application/octet-stream'; Result := HTTP.HTTPMethod('POST', URL); + Data.Size := 0; if Result then begin Data.Seek(0, soFromBeginning); diff --git a/imapsend.pas b/imapsend.pas index 91b2d85..1e91b08 100644 --- a/imapsend.pas +++ b/imapsend.pas @@ -177,8 +177,8 @@ type {:Append given message to specified folder.} function AppendMess(ToFolder: string; const Mess: TStrings): Boolean; - {:'Delete' message from currect selected folder. It mark message as Deleted. - Real deleting waill be done after sucessfull @link(CloseFolder) or + {:'Delete' message from current selected folder. It mark message as Deleted. + Real deleting will be done after sucessfull @link(CloseFolder) or @link(ExpungeFolder)} function DeleteMess(MessID: integer): boolean; diff --git a/mimeinln.pas b/mimeinln.pas index 978a0f2..4f0331a 100644 --- a/mimeinln.pas +++ b/mimeinln.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.009 | +| Project : Ararat Synapse | 001.001.011 | |==============================================================================| | Content: Inline MIME support procedures and functions | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2006, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2006. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -220,14 +220,7 @@ var begin if NeedInline(Value) then begin - 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, - KOI8_R, KOI8_U - {$IFNDEF CIL} //error URW778 ??? :-O - , GB2312, EUC_KR, ISO_2022_JP, EUC_TW - {$ENDIF} - ]); + c := IdealCharsetCoding(Value, FromCP, IdealCharsets); Result := InlineEncode(Value, FromCP, c); end else @@ -252,7 +245,7 @@ begin if sd = '' then Result := se else - Result := '"' + InlineCodeEx(sd, FromCP) + '"<' + se + '>'; + Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>'; end; {==============================================================================} diff --git a/mimemess.pas b/mimemess.pas index ced9ffb..261c942 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.005.000 | +| Project : Ararat Synapse | 002.005.002 | |==============================================================================| | Content: MIME message object | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2006, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2005. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2006. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -90,7 +90,7 @@ type destructor Destroy; override; {:Clears all data fields.} - procedure Clear; + procedure Clear; virtual; {Add headers from from this object to Value.} procedure EncodeHeaders(const Value: TStrings); virtual; @@ -171,7 +171,7 @@ type destructor Destroy; override; {:Reset component to default state.} - procedure Clear; + procedure Clear; virtual; {:Add MIME part as subpart of PartParent. If you need set root MIME part, then set as PartParent @NIL value. If you need set more then one subpart, @@ -362,7 +362,7 @@ begin if s = '' then s := InlineEmailEx(FCCList[n], FCharsetCode) else - s := s + ' , ' + InlineEmailEx(FCCList[n], FCharsetCode); + s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode); if s <> '' then Value.Insert(0, 'CC: ' + s); Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); @@ -373,7 +373,7 @@ begin if s = '' then s := InlineEmailEx(FToList[n], FCharsetCode) else - s := s + ' , ' + InlineEmailEx(FToList[n], FCharsetCode); + s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode); if s <> '' then Value.Insert(0, 'To: ' + s); Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode)); @@ -624,14 +624,7 @@ begin Secondary := 'plain'; Description := 'Message text'; Disposition := 'inline'; - CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, - [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, - KOI8_R, KOI8_U - {$IFNDEF CIL} //error URW778 ??? :-O - , GB2312, EUC_KR, ISO_2022_JP, EUC_TW - {$ENDIF} - ]); + CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets); EncodingCode := ME_QUOTED_PRINTABLE; EncodePart; EncodePartHeader; diff --git a/mimepart.pas b/mimepart.pas index 9aad90e..6e776c6 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.007.005 | +| Project : Ararat Synapse | 002.007.007 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2005. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -733,7 +733,7 @@ end; procedure TMIMEPart.DecodePart; var n: Integer; - s, t: string; + s, t, t2: string; b: Boolean; begin FDecodedLines.Clear; @@ -758,8 +758,8 @@ begin if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then begin b := false; - t := uppercase(s); - t := SeparateLeft(t, ''); + t2 := uppercase(s); + t := SeparateLeft(t2, ''); if length(t) <> length(s) then begin t := SeparateRight(t, ''); @@ -767,6 +767,15 @@ begin t := ReplaceString(t, ' ', ''); b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; end; + //workaround for shitty M$ Outlook 11 which is placing this information + //outside section + if not b then + begin + t := Copy(t2, 1, 2048); + t := ReplaceString(t, '"', ''); + t := ReplaceString(t, ' ', ''); + b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; + end; if not b then s := CharsetConversion(s, FCharsetCode, FTargetCharset); end @@ -1067,8 +1076,11 @@ end; procedure TMIMEPart.SetCharset(Value: string); begin - FCharset := Value; - FCharsetCode := GetCPFromID(Value); + if value <> '' then + begin + FCharset := Value; + FCharsetCode := GetCPFromID(Value); + end; end; function TMIMEPart.CanSubPart: boolean; diff --git a/nntpsend.pas b/nntpsend.pas index 1617acf..ef35f77 100644 --- a/nntpsend.pas +++ b/nntpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.005.000 | +| Project : Ararat Synapse | 001.005.001 | |==============================================================================| | Content: NNTP client | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -62,7 +62,7 @@ uses blcksock, synautil; const - cNNTPProtocol = 'nntp'; + cNNTPProtocol = '119'; type diff --git a/pingsend.pas b/pingsend.pas index 5e88fc8..ddab79e 100644 --- a/pingsend.pas +++ b/pingsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.001.008 | +| Project : Ararat Synapse | 004.000.000 | |==============================================================================| | Content: PING sender | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -45,11 +45,15 @@ {:@abstract(ICMP PING implementation.) Allows create PING and TRACEROUTE. Or you can diagnose your network. -Warning: this unit using RAW sockets. On some systems you must have special - rights for using this sort of sockets. So, it working allways when you have - administator/root rights. Otherwise you can have problems! +This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying + to use RAW sockets. -Note: IPv6 not working under .NET. It is lack of Microsoft's .NET framework. +Warning: For use of RAW sockets you must have some special rights on some + systems. So, it working allways when you have administator/root rights. + Otherwise you can have problems! + +Note: This unit is NOT portable to .NET! + Use native .NET classes for Ping instead. } {$IFDEF FPC} @@ -69,7 +73,11 @@ interface uses SysUtils, - synsock, blcksock, synautil; + synsock, blcksock, synautil, synafpc, synaip +{$IFDEF WIN32} + , windows +{$ENDIF} + ; const ICMP_ECHO = 8; @@ -83,28 +91,6 @@ const ICMP6_TIME_EXCEEDED = 3; type - {:Record for ICMP ECHO packet header.} - TIcmpEchoHeader = record - i_type: Byte; - i_code: Byte; - i_checkSum: Word; - i_Id: Word; - i_seq: Word; - TimeStamp: integer; - end; - - {:record used internally by TPingSend for compute checksum of ICMPv6 packet - pseudoheader.} - TICMP6Packet = record - in_source: TInAddr6; - in_dest: TInAddr6; - Length: integer; - free0: Byte; - free1: Byte; - free2: Byte; - proto: Byte; - end; - {:List of possible ICMP reply packet types.} TICMPError = ( IE_NoError, @@ -117,10 +103,7 @@ type IE_UnreachPort ); - {:@abstract(Implementation of ICMP PING and ICMPv6 PING.) - - Note: Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} + {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)} TPINGSend = class(TSynaClient) private FSock: TICMPBlockSocket; @@ -137,10 +120,17 @@ type FReplyCode: byte; FReplyError: TICMPError; FReplyErrorDesc: string; + FTTL: Byte; + Fsin: TVarSin; function Checksum(Value: string): Word; function Checksum6(Value: string): Word; function ReadPacket: Boolean; procedure TranslateError; + procedure TranslateErrorIpHlp(value: integer); + function InternalPing(const Host: string): Boolean; + function InternalPingIpHlp(const Host: string): Boolean; + function IsHostIP6(const Host: string): Boolean; + procedure GenErrorDesc; public {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is @true.} @@ -176,6 +166,9 @@ type {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TICMPBlockSocket read FSock; + + {:TTL value for ICMP query} + property TTL: byte read FTTL write FTTL; end; {:A very useful function and example of its use would be found in the TPINGSend @@ -189,6 +182,82 @@ function TraceRouteHost(const Host: string): string; implementation +type + {:Record for ICMP ECHO packet header.} + TIcmpEchoHeader = record + i_type: Byte; + i_code: Byte; + i_checkSum: Word; + i_Id: Word; + i_seq: Word; + TimeStamp: integer; + end; + + {:record used internally by TPingSend for compute checksum of ICMPv6 packet + pseudoheader.} + TICMP6Packet = record + in_source: TInAddr6; + in_dest: TInAddr6; + Length: integer; + free0: Byte; + free1: Byte; + free2: Byte; + proto: Byte; + end; + +{$IFDEF WIN32} +const + DLLIcmpName = 'iphlpapi.dll'; +type + TIP_OPTION_INFORMATION = packed record + TTL: Byte; + TOS: Byte; + Flags: Byte; + OptionsSize: Byte; + OptionsData: PChar; + end; + PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION; + + TICMP_ECHO_REPLY = packed record + Address: TInAddr; + Status: integer; + RoundTripTime: integer; + DataSize: Word; + Reserved: Word; + Data: pointer; + Options: TIP_OPTION_INFORMATION; + end; + PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY; + + TICMPV6_ECHO_REPLY = packed record + Address: TSockAddrIn6; + Status: integer; + RoundTripTime: integer; + end; + PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY; + + TIcmpCreateFile = function: integer; stdcall; + TIcmpCloseHandle = function(handle: integer): boolean; stdcall; + TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; + ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer; + RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; + ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; + TIcmp6CreateFile = function: integer; stdcall; + TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; + ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6; + RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; + ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; + +var + IcmpDllHandle: TLibHandle = 0; + IcmpHelper4: boolean = false; + IcmpHelper6: boolean = false; + IcmpCreateFile: TIcmpCreateFile = nil; + IcmpCloseHandle: TIcmpCloseHandle = nil; + IcmpSendEcho2: TIcmpSendEcho2 = nil; + Icmp6CreateFile: TIcmp6CreateFile = nil; + Icmp6SendEcho2: TIcmp6SendEcho2 = nil; +{$ENDIF} {==============================================================================} constructor TPINGSend.Create; @@ -199,6 +268,7 @@ begin FPacketSize := 32; FSeq := 0; Randomize; + FTTL := 128; end; destructor TPINGSend.Destroy; @@ -213,7 +283,69 @@ begin Result := FSock.LastError = 0; end; +procedure TPINGSend.GenErrorDesc; +begin + 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 TPINGSend.IsHostIP6(const Host: string): Boolean; +var + f: integer; +begin + f := AF_UNSPEC; + if IsIp(Host) then + f := AF_INET + else + if IsIp6(Host) then + f := AF_INET6; + synsock.SetVarSin(Fsin, host, '0', f, + IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4); + result := Fsin.sin_family = AF_INET6; +end; + function TPINGSend.Ping(const Host: string): Boolean; +var + b: boolean; +begin + FPingTime := -1; + FReplyFrom := ''; + FReplyType := 0; + FReplyCode := 0; + FReplyError := IE_Other; + GenErrorDesc; + FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize); +{$IFDEF WIN32} + b := IsHostIP6(host); + if not(b) and IcmpHelper4 then + result := InternalPingIpHlp(host) + else + if b and IcmpHelper6 then + result := InternalPingIpHlp(host) + else + result := InternalPing(host); +{$ELSE} + result := InternalPing(host); +{$ENDIF} +end; + +function TPINGSend.InternalPing(const Host: string): Boolean; var IPHeadPtr: ^TIPHeader; IpHdrLen: Integer; @@ -223,12 +355,7 @@ var IcmpReqHead: string; begin Result := False; - FPingTime := -1; - FReplyFrom := ''; - FReplyType := 0; - FReplyCode := 0; - FReplyError := IE_NoError; - FReplyErrorDesc := ''; + FSock.TTL := FTTL; FSock.Bind(FIPInterface, cAnyPort); FSock.Connect(Host, '0'); if FSock.LastError <> 0 then @@ -246,7 +373,6 @@ begin FIcmpEchoReply := ICMP_ECHOREPLY; FIcmpUnreach := ICMP_UNREACH; end; - FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize); IcmpEchoHeaderPtr := Pointer(FBuffer); with IcmpEchoHeaderPtr^ do begin @@ -414,25 +540,96 @@ begin 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'; + GenErrorDesc; +end; + +procedure TPINGSend.TranslateErrorIpHlp(value: integer); +begin + case value of + 11000, 0: + FReplyError := IE_NoError; + 11013: + FReplyError := IE_TTLExceed; + 11002: + FReplyError := IE_UnreachRoute; + 11003: + FReplyError := IE_UnreachAddr; + 11005: + FReplyError := IE_UnreachPort; + 11004: + FReplyError := IE_UnreachAdmin; + else + FReplyError := IE_Other; + end; + GenErrorDesc; +end; + +function TPINGSend.InternalPingIpHlp(const Host: string): Boolean; +{$IFDEF WIN32} +var + PingIp6: boolean; + PingHandle: integer; + r: integer; + ipo: TIP_OPTION_INFORMATION; + RBuff: string; + ip4reply: PICMP_ECHO_REPLY; + ip6reply: PICMPV6_ECHO_REPLY; + ip6: TSockAddrIn6; +begin + Result := False; + PingIp6 := Fsin.sin_family = AF_INET6; + if pingIp6 then + PingHandle := Icmp6CreateFile + else + PingHandle := IcmpCreateFile; + if PingHandle <> -1 then + begin + try + ipo.TTL := FTTL; + ipo.TOS := 0; + ipo.Flags := 0; + ipo.OptionsSize := 0; + ipo.OptionsData := nil; + setlength(RBuff, 4096); + if pingIp6 then + begin + FillChar(ip6, sizeof(ip6), 0); + r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin, + Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout); + if r > 0 then + begin + RBuff := #0 + #0 + RBuff; + ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff)); + FPingTime := ip6reply^.RoundTripTime; + ip6reply^.Address.sin6_family := AF_INET6; + FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address)); + TranslateErrorIpHlp(ip6reply^.Status); + Result := True; + end; + end + else + begin + r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr, + Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout); + if r > 0 then + begin + ip4reply := PICMP_ECHO_REPLY(pointer(RBuff)); + FPingTime := ip4reply^.RoundTripTime; + FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr)); + TranslateErrorIpHlp(ip4reply^.Status); + Result := True; + end; + end + finally + IcmpCloseHandle(PingHandle); + end; end; end; +{$ELSE} +begin + result := false; +end; +{$ENDIF} {==============================================================================} @@ -459,7 +656,7 @@ begin try ttl := 1; repeat - ping.Sock.TTL := ttl; + ping.TTL := ttl; inc(ttl); if ttl > 30 then Break; @@ -481,4 +678,31 @@ begin end; end; +{$IFDEF WIN32} +initialization +begin + IcmpHelper4 := false; + IcmpHelper6 := false; + IcmpDllHandle := LoadLibrary(DLLIcmpName); + if IcmpDllHandle <> 0 then + begin + IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile'); + IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle'); + IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2'); + Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile'); + Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2'); + IcmpHelper4 := assigned(IcmpCreateFile) + and assigned(IcmpCloseHandle) + and assigned(IcmpSendEcho2); + IcmpHelper6 := assigned(Icmp6CreateFile) + and assigned(Icmp6SendEcho2); + end; +end; + +finalization +begin + FreeLibrary(IcmpDllHandle); +end; +{$ENDIF} + end. diff --git a/pop3send.pas b/pop3send.pas index 790b921..a261c56 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.005.000 | +| Project : Ararat Synapse | 002.006.000 | |==============================================================================| | Content: POP3 client | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2005. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -61,7 +61,7 @@ uses blcksock, synautil, synacode; const - cPop3Protocol = 'pop3'; + cPop3Protocol = '110'; type @@ -98,6 +98,11 @@ type constructor Create; destructor Destroy; override; + {:You can call any custom by this method. Call Command without trailing CRLF. + If MultiLine parameter is @true, multilined response are expected. + Result is @true on sucess.} + function CustomCommand(const Command: string; MultiLine: Boolean): boolean; + {:Call CAPA command for get POP3 server capabilites. note: not all servers support this command!} function Capability: Boolean; @@ -237,17 +242,25 @@ begin Delete(s, 1, 1); FFullResult.Add(s); until FSock.LastError <> 0; + if not Full and (Result = 1) then + FFullResult.Add(SeparateRight(FResultString, ' ')); + if FSock.LastError <> 0 then + Result := 0; FResultCode := Result; end; +function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; +begin + FSock.SendString(Command + CRLF); + Result := ReadResult(MultiLine) <> 0; +end; + function TPOP3Send.AuthLogin: Boolean; begin Result := False; - FSock.SendString('USER ' + FUserName + CRLF); - if ReadResult(False) <> 1 then - Exit; - FSock.SendString('PASS ' + FPassword + CRLF); - Result := ReadResult(False) = 1; + if not CustomCommand('USER ' + FUserName, False) then + exit; + Result := CustomCommand('PASS ' + FPassword, False) end; function TPOP3Send.AuthAPOP: Boolean; @@ -255,8 +268,7 @@ var s: string; begin s := StrToHex(MD5(FTimeStamp + FPassWord)); - FSock.SendString('APOP ' + FUserName + ' ' + s + CRLF); - Result := ReadResult(False) = 1; + Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); end; function TPOP3Send.Connect: Boolean; @@ -278,8 +290,7 @@ end; function TPOP3Send.Capability: Boolean; begin FPOP3cap.Clear; - FSock.SendString('CAPA' + CRLF); - Result := ReadResult(True) = 1; + Result := CustomCommand('CAPA', True); if Result then FPOP3cap.AddStrings(FFullResult); end; @@ -328,35 +339,31 @@ end; function TPOP3Send.Logout: Boolean; begin - FSock.SendString('QUIT' + CRLF); - Result := ReadResult(False) = 1; + Result := CustomCommand('QUIT', False); FSock.CloseSocket; end; function TPOP3Send.Reset: Boolean; begin - FSock.SendString('RSET' + CRLF); - Result := ReadResult(False) = 1; + Result := CustomCommand('RSET', False); end; function TPOP3Send.NoOp: Boolean; begin - FSock.SendString('NOOP' + CRLF); - Result := ReadResult(False) = 1; + Result := CustomCommand('NOOP', False); end; function TPOP3Send.Stat: Boolean; var s: string; begin - Result := False; - FSock.SendString('STAT' + CRLF); - if ReadResult(False) <> 1 then - Exit; - s := SeparateRight(ResultString, '+OK '); - FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); - FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); - Result := True; + Result := CustomCommand('STAT', False); + if Result then + begin + s := SeparateRight(ResultString, '+OK '); + FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); + FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); + end; end; function TPOP3Send.List(Value: Integer): Boolean; @@ -365,10 +372,10 @@ var n: integer; begin if Value = 0 then - FSock.SendString('LIST' + CRLF) + s := 'LIST' else - FSock.SendString('LIST ' + IntToStr(Value) + CRLF); - Result := ReadResult(Value = 0) = 1; + s := 'LIST ' + IntToStr(Value); + Result := CustomCommand(s, Value = 0); FListSize := 0; if Result then if Value <> 0 then @@ -383,8 +390,7 @@ end; function TPOP3Send.Retr(Value: Integer): Boolean; begin - FSock.SendString('RETR ' + IntToStr(Value) + CRLF); - Result := ReadResult(True) = 1; + Result := CustomCommand('RETR ' + IntToStr(Value), True); end; //based on code by Miha Vrhovnik @@ -423,30 +429,29 @@ end; function TPOP3Send.Dele(Value: Integer): Boolean; begin - FSock.SendString('DELE ' + IntToStr(Value) + CRLF); - Result := ReadResult(False) = 1; + Result := CustomCommand('DELE ' + IntToStr(Value), False); end; function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; begin - FSock.SendString('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines) + CRLF); - Result := ReadResult(True) = 1; + Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); end; function TPOP3Send.Uidl(Value: Integer): Boolean; +var + s: string; begin if Value = 0 then - FSock.SendString('UIDL' + CRLF) + s := 'UIDL' else - FSock.SendString('UIDL ' + IntToStr(Value) + CRLF); - Result := ReadResult(Value = 0) = 1; + s := 'UIDL ' + IntToStr(Value); + Result := CustomCommand(s, Value = 0); end; function TPOP3Send.StartTLS: Boolean; begin Result := False; - FSock.SendString('STLS' + CRLF); - if ReadResult(False) = 1 then + if CustomCommand('STLS', False) then begin Fsock.SSLDoConnect; Result := FSock.LastError = 0; diff --git a/smtpsend.pas b/smtpsend.pas index 47ff6fd..c695fca 100644 --- a/smtpsend.pas +++ b/smtpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.004.002 | +| Project : Ararat Synapse | 003.004.003 | |==============================================================================| | Content: SMTP client | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -62,7 +62,7 @@ uses blcksock, synautil, synacode; const - cSmtpProtocol = 'smtp'; + cSmtpProtocol = '25'; type {:@abstract(Implementation of SMTP and ESMTP procotol), diff --git a/snmpsend.pas b/snmpsend.pas index e5c2939..d8909cf 100644 --- a/snmpsend.pas +++ b/snmpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.000.008 | +| Project : Ararat Synapse | 003.000.009 | |==============================================================================| | Content: SNMP client | |==============================================================================| -| Copyright (c)1999-2004, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -679,6 +679,7 @@ begin ASNObject(Self.FCommunity, ASN1_OCTSTR); Result := ASNObject(head + pdu, ASN1_SEQ); end; + inc(self.FID); end; procedure TSNMPRec.Clear; diff --git a/sntpsend.pas b/sntpsend.pas index dd40de3..c4958b2 100644 --- a/sntpsend.pas +++ b/sntpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.000.001| +| Project : Ararat Synapse | 003.000.002 | |==============================================================================| | Content: SNTP client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -63,7 +63,7 @@ uses synsock, blcksock, synautil; const - cNtpProtocol = 'ntp'; + cNtpProtocol = '123'; type diff --git a/ssfpc.pas b/ssfpc.pas index 6957bbf..cf0c7d6 100644 --- a/ssfpc.pas +++ b/ssfpc.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.003 | +| Project : Ararat Synapse | 001.000.005 | |==============================================================================| | Content: Socket Independent Platform Layer - FreePascal definition include | |==============================================================================| @@ -83,6 +83,8 @@ const cLocalHost = '127.0.0.1'; cAnyHost = '0.0.0.0'; c6AnyHost = '::0'; + c6Localhost = '::1'; + cLocalHostStr = 'localhost'; type TSocket = longint; @@ -675,11 +677,16 @@ var end else begin - a4[1].s_addr := 0; - Result := WSAHOST_NOT_FOUND; - a4[1] := StrTonetAddr(IP); - if a4[1].s_addr = INADDR_ANY then - Resolvename(ip, a4); + if lowercase(IP) = cLocalHostStr then + a4[1].s_addr := htonl(INADDR_LOOPBACK) + else + begin + a4[1].s_addr := 0; + Result := WSAHOST_NOT_FOUND; + a4[1] := StrTonetAddr(IP); + if a4[1].s_addr = INADDR_ANY then + Resolvename(ip, a4); + end; if a4[1].s_addr <> INADDR_ANY then begin Sin.sin_family := AF_INET; @@ -697,11 +704,16 @@ var end else begin - Result := WSAHOST_NOT_FOUND; - SET_IN6_IF_ADDR_ANY(@a6[1]); - a6[1] := StrTonetAddr6(IP); - if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - Resolvename6(ip, a6); + if lowercase(IP) = cLocalHostStr then + SET_LOOPBACK_ADDR6(@a6[1]) + else + begin + Result := WSAHOST_NOT_FOUND; + SET_IN6_IF_ADDR_ANY(@a6[1]); + a6[1] := StrTonetAddr6(IP); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + Resolvename6(ip, a6); + end; if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then begin Sin.sin_family := AF_INET6; @@ -772,26 +784,36 @@ begin IPList.Clear; if (family = AF_INET) or (family = AF_UNSPEC) then begin - a4[1] := StrTonetAddr(name); - if a4[1].s_addr = INADDR_ANY then - x := Resolvename(name, a4) + if lowercase(name) = cLocalHostStr then + IpList.Add(cLocalHost) else - x := 1; - for n := 1 to x do - IpList.Add(netaddrToStr(a4[n])); + begin + a4[1] := StrTonetAddr(name); + if a4[1].s_addr = INADDR_ANY then + x := Resolvename(name, a4) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr(a4[n])); + end; end; if (family = AF_INET6) or (family = AF_UNSPEC) then begin - a6[1] := StrTonetAddr6(name); - if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - x := Resolvename6(name, a6) + if lowercase(name) = cLocalHostStr then + IpList.Add(c6LocalHost) else - x := 1; - for n := 1 to x do - IpList.Add(netaddrToStr6(a6[n])); + begin + a6[1] := StrTonetAddr6(name); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + x := Resolvename6(name, a6) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr6(a6[n])); + end; end; - + if IPList.Count = 0 then IPList.Add(cLocalHost); end; diff --git a/ssl_sbb.pas b/ssl_sbb.pas index 5692fd6..c9380a4 100644 --- a/ssl_sbb.pas +++ b/ssl_sbb.pas @@ -1,594 +1,697 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.000.001 | -|==============================================================================| -| Content: SSL support for SecureBlackBox | -|==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2005. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Allen Drennan (adrennan@wiredred.com) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SSL plugin for Eldos SecureBlackBox) - -For handling keys and certificates you can use this properties: -@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), -@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), -@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), -@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), -@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats -of keys and certificates refer to SecureBlackBox documentation. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit ssl_sbb; - -interface - -uses - SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode, - SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage, - SBUtils, SBConstants, SBSessionPool; - -const - DEFAULT_RECV_BUFFER=32768; - -type - {:@abstract(class implementing SecureBlackbox SSL plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLSBB=class(TCustomSSL) - protected - FServer: Boolean; - FElSecureClient:TElSecureClient; - FElSecureServer:TElSecureServer; - FElCertStorage:TElMemoryCertStorage; - FElX509Certificate:TElX509Certificate; - private - FRecvBuffer:String; - FRecvBuffers:String; - FRecvDecodedBuffers:String; - function Init(Server:Boolean):Boolean; - function DeInit:Boolean; - function Prepare(Server:Boolean):Boolean; - procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); - procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); - procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;out Written:LongInt); - procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); - public - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited and @link(ssl_sbb) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_sbb) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetCertInfo: string; override; - published - property ELSecureClient:TElSecureClient read FElSecureClient write FElSecureClient; - property ELSecureServer:TElSecureServer read FElSecureServer write FElSecureServer; - end; - -implementation - -// on error -procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); - -begin - FLastErrorDesc:=''; - FLastError:=ErrorCode; -end; - -// on send -procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); - -var - lResult:Integer; - -begin - lResult:=Send(FSocket.Socket,Buffer,Size,0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end; -end; - -// on receive -procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;out Written:LongInt); - -begin - if Length(FRecvBuffers)<=MaxSize then - begin - Written:=Length(FRecvBuffers); - Move(FRecvBuffers[1],Buffer^,Written); - FRecvBuffers:=''; - end - else - begin - Written:=MaxSize; - Move(FRecvBuffers[1],Buffer^,Written); - Delete(FRecvBuffers,1,Written); - end; -end; - -// on data -procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); - -var - lString:String; - -begin - SetLength(lString,Size); - Move(Buffer^,lString[1],Size); - FRecvDecodedBuffers:=FRecvDecodedBuffers+lString; -end; - -{ inherited } - -constructor TSSLSBB.Create(const Value: TTCPBlockSocket); - -begin - inherited Create(Value); - FServer:=FALSE; - FElSecureClient:=NIL; - FElSecureServer:=NIL; - FElCertStorage:=NIL; - FElX509Certificate:=NIL; - SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER); - FRecvBuffers:=''; - FRecvDecodedBuffers:=''; -end; - -destructor TSSLSBB.Destroy; - -begin - DeInit; - inherited Destroy; -end; - -function TSSLSBB.LibVersion: String; - -begin - Result:='SecureBlackBox'; -end; - -function TSSLSBB.LibName: String; - -begin - Result:='ssl_sbb'; -end; - -function FileToString(lFile:String):String; - -var - lStream:TMemoryStream; - -begin - Result:=''; - lStream:=TMemoryStream.Create; - if lStream<>NIL then - begin - lStream.LoadFromFile(lFile); - if lStream.Size>0 then - begin - lStream.Position:=0; - SetLength(Result,lStream.Size); - Move(lStream.Memory^,Result[1],lStream.Size); - end; - lStream.Free; - end; -end; - -function TSSLSBB.Init(Server:Boolean):Boolean; - -var - loop1:Integer; - lStream:TMemoryStream; - lCertificate,lPrivateKey:String; - -begin - Result:=FALSE; - FServer:=Server; - - // init, certificate - if FCertificateFile<>'' then - lCertificate:=FileToString(FCertificateFile) - else - lCertificate:=FCertificate; - if FPrivateKeyFile<>'' then - lPrivateKey:=FileToString(FPrivateKeyFile) - else - lPrivateKey:=FPrivateKey; - if (lCertificate<>'') and (lPrivateKey<>'') then - begin - FElX509Certificate:=TElX509Certificate.Create(NIL); - if FElX509Certificate<>NIL then - begin - with FElX509Certificate do - begin - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lCertificate); - lStream.Seek(0,soFromBeginning); - LoadFromStream(lStream); - finally - lStream.Free; - end; - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lPrivateKey); - lStream.Seek(0,soFromBeginning); - LoadKeyFromStream(lStream); - finally - lStream.Free; - end; - FElCertStorage:=TElMemoryCertStorage.Create(NIL); - if FElCertStorage<>NIL then - begin - FElCertStorage.Clear; - FElCertStorage.Add(FElX509Certificate); - end; - end; - end; - end; - - // init, as server - if FServer then - begin - FElSecureServer:=TElSecureServer.Create(NIL); - if FElSecureServer<>NIL then - begin - // init, ciphers - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FElSecureServer.CipherSuites[loop1]:=TRUE; - FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1]; - FElSecureServer.ClientAuthentication:=FALSE; - FElSecureServer.OnError:=OnError; - FElSecureServer.OnSend:=OnSend; - FElSecureServer.OnReceive:=OnReceive; - FElSecureServer.OnData:=OnData; - FElSecureServer.CertStorage:=FElCertStorage; - Result:=TRUE; - end; - end - else - // init, as client - begin - FElSecureClient:=TElSecureClient.Create(NIL); - if FElSecureClient<>NIL then - begin - // init, ciphers - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FElSecureClient.CipherSuites[loop1]:=TRUE; - FElSecureClient.Versions:=[sbSSL3,sbTLS1]; - FElSecureClient.OnError:=OnError; - FElSecureClient.OnSend:=OnSend; - FElSecureClient.OnReceive:=OnReceive; - FElSecureClient.OnData:=OnData; - FElSecureClient.CertStorage:=FElCertStorage; - Result:=TRUE; - end; - end; -end; - -function TSSLSBB.DeInit:Boolean; - -begin - Result:=TRUE; - if FElSecureServer<>NIL then - FreeAndNIL(FElSecureServer); - if FElSecureClient<>NIL then - FreeAndNIL(FElSecureClient); - if FElX509Certificate<>NIL then - FreeAndNIL(FElX509Certificate); - if FElCertStorage<>NIL then - FreeAndNIL(FElCertStorage); - FSSLEnabled:=FALSE; -end; - -function TSSLSBB.Prepare(Server:Boolean): Boolean; - -begin - Result:=FALSE; - DeInit; - if Init(Server) then - Result:=TRUE - else - DeInit; -end; - -function TSSLSBB.Connect: boolean; - -var - lResult:Integer; - -begin - Result:=FALSE; - if FSocket.Socket=INVALID_SOCKET then - Exit; - if Prepare(FALSE) then - begin - FElSecureClient.Open; - - // wait for open or error - while (not FElSecureClient.Active) and - (FLastError=0) do - begin - // data available? - if FRecvBuffers<>'' then - FElSecureClient.DataAvailable - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if lResult>0 then - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) - else - Break; - end; - end; - end; - if FLastError<>0 then - Exit; - FSSLEnabled:=FElSecureClient.Active; - Result:=FSSLEnabled; - end; -end; - -function TSSLSBB.Accept: boolean; - -var - lResult:Integer; - -begin - Result:=FALSE; - if FSocket.Socket=INVALID_SOCKET then - Exit; - if Prepare(TRUE) then - begin - FElSecureServer.Open; - - // wait for open or error - while (not FElSecureServer.Active) and - (FLastError=0) do - begin - // data available? - if FRecvBuffers<>'' then - FElSecureServer.DataAvailable - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if lResult>0 then - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) - else - Break; - end; - end; - end; - if FLastError<>0 then - Exit; - FSSLEnabled:=FElSecureServer.Active; - Result:=FSSLEnabled; - end; -end; - -function TSSLSBB.Shutdown: boolean; - -begin - Result:=BiShutdown; -end; - -function TSSLSBB.BiShutdown: boolean; - -begin - DeInit; - Result:=TRUE; -end; - -function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer; - -begin - if FServer then - FElSecureServer.SendData(Buffer,Len) - else - FElSecureClient.SendData(Buffer,Len); - Result:=Len; -end; - -function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; - -begin - if Length(FRecvDecodedBuffers)'' then - begin - if FServer then - FElSecureServer.DataAvailable - else - FElSecureClient.DataAvailable; - end - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult); - - // data available? - if FRecvBuffers<>'' then - begin - if FServer then - FElSecureServer.DataAvailable - else - FElSecureClient.DataAvailable; - end; - end; - Result:=Length(FRecvDecodedBuffers); -end; - -function TSSLSBB.GetSSLVersion: string; - -begin - Result:='SSLv3 or TLSv1'; -end; - -function TSSLSBB.GetPeerSubject: string; - -begin - Result := ''; -// if FServer then - // must return subject of the client certificate -// else - // must return subject of the server certificate -end; - -function TSSLSBB.GetPeerName: string; - -begin - Result := ''; -// if FServer then - // must return commonname of the client certificate -// else - // must return commonname of the server certificate -end; - -function TSSLSBB.GetPeerIssuer: string; - -begin - Result := ''; -// if FServer then - // must return issuer of the client certificate -// else - // must return issuer of the server certificate -end; - -function TSSLSBB.GetPeerFingerprint: string; - -begin - Result := ''; -// if FServer then - // must return a unique hash string of the client certificate -// else - // must return a unique hash string of the server certificate -end; - -function TSSLSBB.GetCertInfo: string; - -begin - Result := ''; -// if FServer then - // must return a text representation of the ASN of the client certificate -// else - // must return a text representation of the ASN of the server certificate -end; - -{==============================================================================} - -initialization - SSLImplementation := TSSLSBB; - -finalization - -end. +{==============================================================================| +| Project : Ararat Synapse | 001.000.003 | +|==============================================================================| +| Content: SSL support for SecureBlackBox | +|==============================================================================| +| Copyright (c)1999-2005, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2005. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Allen Drennan (adrennan@wiredred.com) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SSL plugin for Eldos SecureBlackBox) + +For handling keys and certificates you can use this properties: +@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), +@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), +@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), +@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), +@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats +of keys and certificates refer to SecureBlackBox documentation. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_sbb; + +interface + +uses + SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode, + SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage, + SBUtils, SBConstants, SBSessionPool; + +const + DEFAULT_RECV_BUFFER=32768; + +type + {:@abstract(class implementing SecureBlackbox SSL plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLSBB=class(TCustomSSL) + protected + FServer: Boolean; + FElSecureClient:TElSecureClient; + FElSecureServer:TElSecureServer; + FElCertStorage:TElMemoryCertStorage; + FElX509Certificate:TElX509Certificate; + FElX509CACertificate:TElX509Certificate; + FCipherSuites:TBits; + private + FRecvBuffer:String; + FRecvBuffers:String; + FRecvBuffersLock:TRTLCriticalSection; + FRecvDecodedBuffers:String; + function GetCipherSuite:Integer; + procedure Reset; + function Prepare(Server:Boolean):Boolean; + procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); + procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); + procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); + procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); + public + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited and @link(ssl_sbb) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_sbb) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetCertInfo: string; override; + published + property ElSecureClient:TElSecureClient read FElSecureClient write FElSecureClient; + property ElSecureServer:TElSecureServer read FElSecureServer write FElSecureServer; + property CipherSuites:TBits read FCipherSuites write FCipherSuites; + property CipherSuite:Integer read GetCipherSuite; + end; + +implementation + +var + FAcceptThread:THandle=0; + +// on error +procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); + +begin + FLastErrorDesc:=''; + FLastError:=ErrorCode; +end; + +// on send +procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); + +var + lResult:Integer; + +begin + if FSocket.Socket=INVALID_SOCKET then + Exit; + lResult:=Send(FSocket.Socket,Buffer,Size,0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end; +end; + +// on receive +procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); + +begin + if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + if Length(FRecvBuffers)<=MaxSize then + begin + Written:=Length(FRecvBuffers); + Move(FRecvBuffers[1],Buffer^,Written); + FRecvBuffers:=''; + end + else + begin + Written:=MaxSize; + Move(FRecvBuffers[1],Buffer^,Written); + Delete(FRecvBuffers,1,Written); + end; + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; +end; + +// on data +procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); + +var + lString:String; + +begin + SetLength(lString,Size); + Move(Buffer^,lString[1],Size); + FRecvDecodedBuffers:=FRecvDecodedBuffers+lString; +end; + +{ inherited } + +constructor TSSLSBB.Create(const Value: TTCPBlockSocket); + +var + loop1:Integer; + +begin + inherited Create(Value); + FServer:=FALSE; + FElSecureClient:=NIL; + FElSecureServer:=NIL; + FElCertStorage:=NIL; + FElX509Certificate:=NIL; + FElX509CACertificate:=NIL; + SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER); + FRecvBuffers:=''; + InitializeCriticalSection(FRecvBuffersLock); + FRecvDecodedBuffers:=''; + FCipherSuites:=TBits.Create; + if FCipherSuites<>NIL then + begin + FCipherSuites.Size:=SB_SUITE_LAST+1; + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FCipherSuites[loop1]:=TRUE; + end; +end; + +destructor TSSLSBB.Destroy; + +begin + Reset; + inherited Destroy; + if FCipherSuites<>NIL then + FreeAndNIL(FCipherSuites); + DeleteCriticalSection(FRecvBuffersLock); +end; + +function TSSLSBB.LibVersion: String; + +begin + Result:='SecureBlackBox'; +end; + +function TSSLSBB.LibName: String; + +begin + Result:='ssl_sbb'; +end; + +function FileToString(lFile:String):String; + +var + lStream:TMemoryStream; + +begin + Result:=''; + lStream:=TMemoryStream.Create; + if lStream<>NIL then + begin + lStream.LoadFromFile(lFile); + if lStream.Size>0 then + begin + lStream.Position:=0; + SetLength(Result,lStream.Size); + Move(lStream.Memory^,Result[1],lStream.Size); + end; + lStream.Free; + end; +end; + +function TSSLSBB.GetCipherSuite:Integer; + +begin + if FServer then + Result:=FElSecureServer.CipherSuite + else + Result:=FElSecureClient.CipherSuite; +end; + +procedure TSSLSBB.Reset; + +begin + if FElSecureServer<>NIL then + FreeAndNIL(FElSecureServer); + if FElSecureClient<>NIL then + FreeAndNIL(FElSecureClient); + if FElX509Certificate<>NIL then + FreeAndNIL(FElX509Certificate); + if FElX509CACertificate<>NIL then + FreeAndNIL(FElX509CACertificate); + if FElCertStorage<>NIL then + FreeAndNIL(FElCertStorage); + FSSLEnabled:=FALSE; +end; + +function TSSLSBB.Prepare(Server:Boolean): Boolean; + +var + loop1:Integer; + lStream:TMemoryStream; + lCertificate,lPrivateKey,lCertCA:String; + +begin + Result:=FALSE; + FServer:=Server; + + // reset, if necessary + Reset; + + // init, certificate + if FCertificateFile<>'' then + lCertificate:=FileToString(FCertificateFile) + else + lCertificate:=FCertificate; + if FPrivateKeyFile<>'' then + lPrivateKey:=FileToString(FPrivateKeyFile) + else + lPrivateKey:=FPrivateKey; + if FCertCAFile<>'' then + lCertCA:=FileToString(FCertCAFile) + else + lCertCA:=FCertCA; + if (lCertificate<>'') and (lPrivateKey<>'') then + begin + FElCertStorage:=TElMemoryCertStorage.Create(NIL); + if FElCertStorage<>NIL then + FElCertStorage.Clear; + + // apply ca certificate + if lCertCA<>'' then + begin + FElX509CACertificate:=TElX509Certificate.Create(NIL); + if FElX509CACertificate<>NIL then + begin + with FElX509CACertificate do + begin + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lCertCA); + lStream.Seek(0,soFromBeginning); + LoadFromStream(lStream); + finally + lStream.Free; + end; + end; + if FElCertStorage<>NIL then + FElCertStorage.Add(FElX509CACertificate); + end; + end; + + // apply certificate + FElX509Certificate:=TElX509Certificate.Create(NIL); + if FElX509Certificate<>NIL then + begin + with FElX509Certificate do + begin + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lCertificate); + lStream.Seek(0,soFromBeginning); + LoadFromStream(lStream); + finally + lStream.Free; + end; + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lPrivateKey); + lStream.Seek(0,soFromBeginning); + LoadKeyFromStream(lStream); + finally + lStream.Free; + end; + if FElCertStorage<>NIL then + FElCertStorage.Add(FElX509Certificate); + end; + end; + end; + + // init, as server + if FServer then + begin + FElSecureServer:=TElSecureServer.Create(NIL); + if FElSecureServer<>NIL then + begin + // init, ciphers + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FElSecureServer.CipherSuites[loop1]:=FCipherSuites[loop1]; + FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1]; + FElSecureServer.ClientAuthentication:=FALSE; + FElSecureServer.OnError:=OnError; + FElSecureServer.OnSend:=OnSend; + FElSecureServer.OnReceive:=OnReceive; + FElSecureServer.OnData:=OnData; + FElSecureServer.CertStorage:=FElCertStorage; + Result:=TRUE; + end; + end + else + // init, as client + begin + FElSecureClient:=TElSecureClient.Create(NIL); + if FElSecureClient<>NIL then + begin + // init, ciphers + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FElSecureClient.CipherSuites[loop1]:=FCipherSuites[loop1]; + FElSecureClient.Versions:=[sbSSL3,sbTLS1]; + FElSecureClient.OnError:=OnError; + FElSecureClient.OnSend:=OnSend; + FElSecureClient.OnReceive:=OnReceive; + FElSecureClient.OnData:=OnData; + FElSecureClient.CertStorage:=FElCertStorage; + Result:=TRUE; + end; + end; +end; + +function TSSLSBB.Connect:Boolean; + +var + lResult:Integer; + +begin + Result:=FALSE; + if FSocket.Socket=INVALID_SOCKET then + Exit; + if Prepare(FALSE) then + begin + FElSecureClient.Open; + + // reset + FRecvBuffers:=''; + FRecvDecodedBuffers:=''; + + // wait for open or error + while (not FElSecureClient.Active) and + (FLastError=0) do + begin + // data available? + if FRecvBuffers<>'' then + FElSecureClient.DataAvailable + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if lResult>0 then + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) + else + Break; + end; + end; + end; + if FLastError<>0 then + Exit; + FSSLEnabled:=FElSecureClient.Active; + Result:=FSSLEnabled; + end; +end; + +function TSSLSBB.Accept:Boolean; + +var + lResult:Integer; + +begin + Result:=FALSE; + if FSocket.Socket=INVALID_SOCKET then + Exit; + if Prepare(TRUE) then + begin + FAcceptThread:=GetCurrentThreadId; + FElSecureServer.Open; + + // reset + FRecvBuffers:=''; + FRecvDecodedBuffers:=''; + + // wait for open or error + while (not FElSecureServer.Active) and + (FLastError=0) do + begin + // data available? + if FRecvBuffers<>'' then + FElSecureServer.DataAvailable + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if lResult>0 then + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) + else + Break; + end; + end; + end; + if FLastError<>0 then + Exit; + FSSLEnabled:=FElSecureServer.Active; + Result:=FSSLEnabled; + end; +end; + +function TSSLSBB.Shutdown:Boolean; + +begin + Result:=BiShutdown; +end; + +function TSSLSBB.BiShutdown: boolean; + +begin + Reset; + Result:=TRUE; +end; + +function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer; + +begin + if FServer then + FElSecureServer.SendData(Buffer,Len) + else + FElSecureClient.SendData(Buffer,Len); + Result:=Len; +end; + +function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; + +begin + Result:=0; + try + // recv waiting, if necessary + if FRecvDecodedBuffers='' then + WaitingData; + + // received + if Length(FRecvDecodedBuffers)FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + lRecvBuffers:=FRecvBuffers<>''; + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; + if lRecvBuffers then + begin + if FServer then + FElSecureServer.DataAvailable + else + FElSecureClient.DataAvailable; + end + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult); + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; + + // data available? + if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + lRecvBuffers:=FRecvBuffers<>''; + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; + if lRecvBuffers then + begin + if FServer then + FElSecureServer.DataAvailable + else + FElSecureClient.DataAvailable; + end; + end; + end; + + // decoded buffers result + Result:=Length(FRecvDecodedBuffers); +end; + +function TSSLSBB.GetSSLVersion: string; + +begin + Result:='SSLv3 or TLSv1'; +end; + +function TSSLSBB.GetPeerSubject: string; + +begin + Result := ''; +// if FServer then + // must return subject of the client certificate +// else + // must return subject of the server certificate +end; + +function TSSLSBB.GetPeerName: string; + +begin + Result := ''; +// if FServer then + // must return commonname of the client certificate +// else + // must return commonname of the server certificate +end; + +function TSSLSBB.GetPeerIssuer: string; + +begin + Result := ''; +// if FServer then + // must return issuer of the client certificate +// else + // must return issuer of the server certificate +end; + +function TSSLSBB.GetPeerFingerprint: string; + +begin + Result := ''; +// if FServer then + // must return a unique hash string of the client certificate +// else + // must return a unique hash string of the server certificate +end; + +function TSSLSBB.GetCertInfo: string; + +begin + Result := ''; +// if FServer then + // must return a text representation of the ASN of the client certificate +// else + // must return a text representation of the ASN of the server certificate +end; + +{==============================================================================} + +initialization + SSLImplementation := TSSLSBB; + +finalization + +end. diff --git a/ssl_streamsec.pas b/ssl_streamsec.pas index ec54b60..8c36ac8 100644 --- a/ssl_streamsec.pas +++ b/ssl_streamsec.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.005 | +| Project : Ararat Synapse | 001.000.006 | |==============================================================================| | Content: SSL support by StreamSecII | |==============================================================================| @@ -98,6 +98,7 @@ type FSlave: TMyTLSSynSockSlave; FIsServer: Boolean; FTLSServer: TCustomTLSInternalServer; + FServerCreated: Boolean; function SSLCheck: Boolean; function Init(server:Boolean): Boolean; function DeInit: Boolean; @@ -204,7 +205,7 @@ end; function TSSLStreamSec.Init(server:Boolean): Boolean; var st: TMemoryStream; - pass: TSecretKey; + pass: ISecretKey; ws: WideString; begin Result := False; @@ -218,8 +219,10 @@ begin else if Assigned(TLSInternalServer.GlobalServer) then FSlave.MyTLSServer := TLSInternalServer.GlobalServer - else + else begin FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil); + FServerCreated := True; + end; if server then FSlave.MyTLSServer.ClientOrServer := cosServerSide else @@ -293,7 +296,7 @@ begin end; if FPFXfile <> '' then FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass); - if server then + if server and FServerCreated then begin FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer; FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed; @@ -306,17 +309,24 @@ begin end; Result := true; finally - pass.Free; + pass := nil; end; end; function TSSLStreamSec.DeInit: Boolean; +var + obj: TObject; begin Result := True; if assigned(FSlave) then begin FSlave.Close; + if FServerCreated then + obj := FSlave.TLSServer + else + obj := nil; FSlave.Free; + obj.Free; FSlave := nil; end; FSSLEnabled := false; @@ -355,7 +365,7 @@ begin Exit; if Prepare(true) then begin - FSlave.Open; + FSlave.DoConnect; SSLCheck; if FLastError <> 0 then Exit; @@ -526,3 +536,4 @@ finalization end. + diff --git a/sslinux.pas b/sslinux.pas index 887b666..c337281 100644 --- a/sslinux.pas +++ b/sslinux.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.000.007 | +| Project : Ararat Synapse | 002.000.008 | |==============================================================================| | Content: Socket Independent Platform Layer - Linux definition include | |==============================================================================| @@ -163,7 +163,7 @@ type 0: (S6_addr: packed array [0..15] of byte); 1: (u6_addr8: packed array [0..15] of byte); 2: (u6_addr16: packed array [0..7] of word); - 3: (u6_addr32: packed array [0..7] of integer); + 3: (u6_addr32: packed array [0..3] of integer); end; PSockAddrIn6 = ^TSockAddrIn6; diff --git a/sswin32.pas b/sswin32.pas index 2e0824c..7cc1ed9 100644 --- a/sswin32.pas +++ b/sswin32.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.000.001 | +| Project : Ararat Synapse | 002.000.002 | |==============================================================================| | Content: Socket Independent Platform Layer - Win32 definition include | |==============================================================================| @@ -347,7 +347,7 @@ type 0: (S6_addr: packed array [0..15] of byte); 1: (u6_addr8: packed array [0..15] of byte); 2: (u6_addr16: packed array [0..7] of word); - 3: (u6_addr32: packed array [0..7] of integer); + 3: (u6_addr32: packed array [0..3] of integer); end; PSockAddrIn6 = ^TSockAddrIn6; diff --git a/synachar.pas b/synachar.pas index 586341e..da7c7f7 100644 --- a/synachar.pas +++ b/synachar.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 005.001.003 | +| Project : Ararat Synapse | 005.002.002 | |==============================================================================| | Content: Charset conversion support | |==============================================================================| @@ -66,7 +66,13 @@ interface uses {$IFNDEF WIN32} + {$IFNDEF FPC} Libc, + {$ELSE} + {$IFDEF FPC_USE_LIBC} + Libc, + {$ENDIF} + {$ENDIF} {$ELSE} Windows, {$ENDIF} @@ -153,6 +159,16 @@ var {:By this you can generally disable/enable Iconv support.} DisableIconv: Boolean = False; + {:Default set of charsets for @link(IdealCharsetCoding) function.} + IdealCharsets: TMimeSetChar = + [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, + KOI8_R, KOI8_U + {$IFNDEF CIL} //error URW778 ??? :-O + , GB2312, EUC_KR, ISO_2022_JP, EUC_TW + {$ENDIF} + ]; + {==============================================================================} {:Convert Value from one charset to another. See: @link(CharsetConversionEx)} function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; @@ -1473,7 +1489,16 @@ end; function GetCurCP: TMimeChar; begin + {$IFNDEF FPC} Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); + {$ELSE} + {$IFDEF FPC_USE_LIBC} + Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); + {$ELSE} + //How to get system codepage without LIBC? + Result := UTF_8; + {$ENDIF} + {$ENDIF} end; function GetCurOEMCP: TMimeChar; @@ -1823,7 +1848,7 @@ begin IconvArr[23].Charset := ISO_8859_7; IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK'; IconvArr[24].Charset := ISO_8859_8; - IconvArr[24].Charname := 'ISO_8859-8 HEBREW ISO-8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW'; + IconvArr[24].Charname := 'ISO-8859-8 HEBREW ISO_8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW ISO-8859-8-I'; IconvArr[25].Charset := ISO_8859_9; IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5'; IconvArr[26].Charset := ISO_8859_10; diff --git a/synacode.pas b/synacode.pas index 72e62fd..f183c8c 100644 --- a/synacode.pas +++ b/synacode.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.001.004 | +| Project : Ararat Synapse | 002.002.000 | |==============================================================================| | Content: Coding and decoding support | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -212,6 +212,9 @@ function HMAC_SHA1(Text, Key: AnsiString): AnsiString; by repeating "value" until length is "Len".} function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; +{:Returns a binary string with a RSA-MD4 hashing of "Value" string.} +function MD4(const Value: AnsiString): AnsiString; + implementation const @@ -359,14 +362,11 @@ begin end; type - TMD5Ctx = record + TMDCtx = record State: array[0..3] of Integer; Count: array[0..1] of Integer; BufAnsiChar: array[0..63] of Byte; BufLong: array[0..15] of Integer; -// case Integer of -// 0: (BufAnsiChar: array[0..63] of Byte); -// 1: (BufLong: array[0..15] of Integer); end; TSHA1Ctx= record Hi, Lo: integer; @@ -374,11 +374,10 @@ type Index: integer; Hash: array[0..4] of Integer; HashByte: array[0..19] of byte; -// case Integer of -// 0: (Hash: array[0..4] of Integer); -// 1: (HashByte: array[0..19] of byte); end; + TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt); + {==============================================================================} function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; @@ -847,20 +846,20 @@ end; {==============================================================================} -procedure MD5Init(var MD5Context: TMD5Ctx); +procedure MDInit(var MDContext: TMDCtx); var n: integer; begin - MD5Context.Count[0] := 0; - MD5Context.Count[1] := 0; - for n := 0 to high(MD5Context.BufAnsiChar) do - MD5Context.BufAnsiChar[n] := 0; - for n := 0 to high(MD5Context.BufLong) do - MD5Context.BufLong[n] := 0; - MD5Context.State[0] := Integer($67452301); - MD5Context.State[1] := Integer($EFCDAB89); - MD5Context.State[2] := Integer($98BADCFE); - MD5Context.State[3] := Integer($10325476); + MDContext.Count[0] := 0; + MDContext.Count[1] := 0; + for n := 0 to high(MDContext.BufAnsiChar) do + MDContext.BufAnsiChar[n] := 0; + for n := 0 to high(MDContext.BufLong) do + MDContext.BufLong[n] := 0; + MDContext.State[0] := Integer($67452301); + MDContext.State[1] := Integer($EFCDAB89); + MDContext.State[2] := Integer($98BADCFE); + MDContext.State[3] := Integer($10325476); end; procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); @@ -975,7 +974,7 @@ begin end; //fixed by James McAdams -procedure MD5Update(var MD5Context: TMD5Ctx; const Data: AnsiString); +procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform); var Index, partLen, InputLen, I: integer; {$IFDEF CIL} @@ -983,7 +982,7 @@ var {$ENDIF} begin InputLen := Length(Data); - with MD5Context do + with MDContext do begin Index := (Count[0] shr 3) and $3F; Inc(Count[0], InputLen shl 3); @@ -1001,7 +1000,7 @@ begin Move(Data[1], BufAnsiChar[Index], partLen); {$ENDIF} ArrByteToLong(BufAnsiChar, BufLong); - MD5Transform(State, Buflong); + Transform(State, Buflong); I := partLen; while I + 63 < InputLen do begin @@ -1013,7 +1012,7 @@ begin Move(Data[I+1], BufAnsiChar, 64); {$ENDIF} ArrByteToLong(BufAnsiChar, BufLong); - MD5Transform(State, Buflong); + Transform(State, Buflong); inc(I, 64); end; Index := 0; @@ -1031,7 +1030,7 @@ begin end end; -function MD5Final(var MD5Context: TMD5Ctx): AnsiString; +function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString; var Cnt: Word; P: Byte; @@ -1041,7 +1040,7 @@ var begin for I := 0 to 15 do Digest[I] := I + 1; - with MD5Context do + with MDContext do begin Cnt := (Count[0] shr 3) and $3F; P := Cnt; @@ -1054,7 +1053,7 @@ begin BufAnsiChar[P + n] := 0; ArrByteToLong(BufAnsiChar, BufLong); // FillChar(BufAnsiChar[P], Cnt, #0); - MD5Transform(State, BufLong); + Transform(State, BufLong); ArrLongToByte(BufLong, BufAnsiChar); for n := 0 to 55 do BufAnsiChar[n] := 0; @@ -1070,7 +1069,7 @@ begin end; BufLong[14] := Count[0]; BufLong[15] := Count[1]; - MD5Transform(State, BufLong); + Transform(State, BufLong); ArrLongToByte(State, Digest); // Move(State, Digest, 16); Result := ''; @@ -1084,11 +1083,11 @@ end; function MD5(const Value: AnsiString): AnsiString; var - MD5Context: TMD5Ctx; + MDContext: TMDCtx; begin - MD5Init(MD5Context); - MD5Update(MD5Context, Value); - Result := MD5Final(MD5Context); + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); end; {==============================================================================} @@ -1097,7 +1096,7 @@ function HMAC_MD5(Text, Key: AnsiString): AnsiString; var ipad, opad, s: AnsiString; n: Integer; - MD5Context: TMD5Ctx; + MDContext: TMDCtx; begin if Length(Key) > 64 then Key := md5(Key); @@ -1108,14 +1107,14 @@ begin ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); end; - MD5Init(MD5Context); - MD5Update(MD5Context, ipad); - MD5Update(MD5Context, Text); - s := MD5Final(MD5Context); - MD5Init(MD5Context); - MD5Update(MD5Context, opad); - MD5Update(MD5Context, s); - Result := MD5Final(MD5Context); + MDInit(MDContext); + MDUpdate(MDContext, ipad, @MD5Transform); + MDUpdate(MDContext, Text, @MD5Transform); + s := MDFinal(MDContext, @MD5Transform); + MDInit(MDContext); + MDUpdate(MDContext, opad, @MD5Transform); + MDUpdate(MDContext, s, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); end; {==============================================================================} @@ -1125,17 +1124,17 @@ var cnt, rest: integer; l: integer; n: integer; - MD5Context: TMD5Ctx; + MDContext: TMDCtx; begin l := length(Value); cnt := Len div l; rest := Len mod l; - MD5Init(MD5Context); + MDInit(MDContext); for n := 1 to cnt do - MD5Update(MD5Context, Value); + MDUpdate(MDContext, Value, @MD5Transform); if rest > 0 then - MD5Update(MD5Context, Copy(Value, 1, rest)); - Result := MD5Final(MD5Context); + MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); end; {==============================================================================} @@ -1368,5 +1367,88 @@ end; {==============================================================================} +procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); +var + A, B, C, D: LongInt; + function LRot32(a, b: longint): longint; + begin + Result:= (a shl b) or (a shr (32 - b)); + end; +begin + A := Buf[0]; + B := Buf[1]; + C := Buf[2]; + D := Buf[3]; + + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); + + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13); + + A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15); + + Inc(Buf[0], A); + Inc(Buf[1], B); + Inc(Buf[2], C); + Inc(Buf[3], D); +end; + +{==============================================================================} + +function MD4(const Value: AnsiString): AnsiString; +var + MDContext: TMDCtx; +begin + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD4Transform); + Result := MDFinal(MDContext, @MD4Transform); +end; + +{==============================================================================} + end. diff --git a/synacrypt.pas b/synacrypt.pas new file mode 100644 index 0000000..c80e891 --- /dev/null +++ b/synacrypt.pas @@ -0,0 +1,1223 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: Encryption support | +|==============================================================================| +| Copyright (c)2007, 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)2007. | +| All Rights Reserved. | +| Based on work of David Barton and Eric Young | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Encryption support) + +Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit, + CFB-block, OFB and CTR methods. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +unit synacrypt; + +interface + +uses + SysUtils, Classes, synautil; + +type + {:@abstract(Implementation of common routines for 64-bit block ciphers) + + Do not use this class directly, use descendants only!} + TSynaBlockCipher= class(TObject) + protected + procedure InitKey(Key: AnsiString); virtual; + private + IV, CV: AnsiString; + procedure IncCounter; + public + {:Sets the IV to Value and performs a reset} + procedure SetIV(const Value: AnsiString); virtual; + {:Returns the current chaining information, not the actual IV} + function GetIV: AnsiString; virtual; + {:Reset any stored chaining information} + procedure Reset; virtual; + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; virtual; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; virtual; + {:Encrypt data using the CBC method of encryption} + function EncryptCBC(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CBC method of decryption} + function DecryptCBC(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CFB (8 bit) method of encryption} + function EncryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CFB (8 bit) method of decryption} + function DecryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CFB (block) method of encryption} + function EncryptCFBblock(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CFB (block) method of decryption} + function DecryptCFBblock(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the OFB method of encryption} + function EncryptOFB(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the OFB method of decryption} + function DecryptOFB(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CTR method of encryption} + function EncryptCTR(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CTR method of decryption} + function DecryptCTR(const Indata: AnsiString): AnsiString; virtual; + {:Create a encryptor/decryptor instance and initialize it by the Key.} + constructor Create(Key: AnsiString); + end; + + {:@abstract(Datatype for holding one DES key data) + + This data type is used internally.} + TDesKeyData = array[0..31] of integer; + + {:@abstract(Implementation of common routines for DES encryption) + + Do not use this class directly, use descendants only!} + TSynaCustomDes = class(TSynaBlockcipher) + protected + procedure DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); + function EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; + function DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; + end; + + {:@abstract(Implementation of DES encryption)} + TSynaDes= class(TSynaCustomDes) + protected + KeyData: TDesKeyData; + procedure InitKey(Key: AnsiString); override; + public + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + + {:@abstract(Implementation of 3DES encryption)} + TSyna3Des= class(TSynaCustomDes) + protected + KeyData: array[0..2] of TDesKeyData; + procedure InitKey(Key: AnsiString); override; + public + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + +{:Call internal test of all DES encryptions. Returns @true if all is OK.} +function TestDes: boolean; +{:Call internal test of all 3DES encryptions. Returns @true if all is OK.} +function Test3Des: boolean; + +{==============================================================================} +implementation + +const + shifts2: array[0..15]of byte= + (0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0); + + des_skb: array[0..7,0..63]of integer=( + ( + (* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + integer($00000000),integer($00000010),integer($20000000),integer($20000010), + integer($00010000),integer($00010010),integer($20010000),integer($20010010), + integer($00000800),integer($00000810),integer($20000800),integer($20000810), + integer($00010800),integer($00010810),integer($20010800),integer($20010810), + integer($00000020),integer($00000030),integer($20000020),integer($20000030), + integer($00010020),integer($00010030),integer($20010020),integer($20010030), + integer($00000820),integer($00000830),integer($20000820),integer($20000830), + integer($00010820),integer($00010830),integer($20010820),integer($20010830), + integer($00080000),integer($00080010),integer($20080000),integer($20080010), + integer($00090000),integer($00090010),integer($20090000),integer($20090010), + integer($00080800),integer($00080810),integer($20080800),integer($20080810), + integer($00090800),integer($00090810),integer($20090800),integer($20090810), + integer($00080020),integer($00080030),integer($20080020),integer($20080030), + integer($00090020),integer($00090030),integer($20090020),integer($20090030), + integer($00080820),integer($00080830),integer($20080820),integer($20080830), + integer($00090820),integer($00090830),integer($20090820),integer($20090830) + ),( + (* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *) + integer($00000000),integer($02000000),integer($00002000),integer($02002000), + integer($00200000),integer($02200000),integer($00202000),integer($02202000), + integer($00000004),integer($02000004),integer($00002004),integer($02002004), + integer($00200004),integer($02200004),integer($00202004),integer($02202004), + integer($00000400),integer($02000400),integer($00002400),integer($02002400), + integer($00200400),integer($02200400),integer($00202400),integer($02202400), + integer($00000404),integer($02000404),integer($00002404),integer($02002404), + integer($00200404),integer($02200404),integer($00202404),integer($02202404), + integer($10000000),integer($12000000),integer($10002000),integer($12002000), + integer($10200000),integer($12200000),integer($10202000),integer($12202000), + integer($10000004),integer($12000004),integer($10002004),integer($12002004), + integer($10200004),integer($12200004),integer($10202004),integer($12202004), + integer($10000400),integer($12000400),integer($10002400),integer($12002400), + integer($10200400),integer($12200400),integer($10202400),integer($12202400), + integer($10000404),integer($12000404),integer($10002404),integer($12002404), + integer($10200404),integer($12200404),integer($10202404),integer($12202404) + ),( + (* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *) + integer($00000000),integer($00000001),integer($00040000),integer($00040001), + integer($01000000),integer($01000001),integer($01040000),integer($01040001), + integer($00000002),integer($00000003),integer($00040002),integer($00040003), + integer($01000002),integer($01000003),integer($01040002),integer($01040003), + integer($00000200),integer($00000201),integer($00040200),integer($00040201), + integer($01000200),integer($01000201),integer($01040200),integer($01040201), + integer($00000202),integer($00000203),integer($00040202),integer($00040203), + integer($01000202),integer($01000203),integer($01040202),integer($01040203), + integer($08000000),integer($08000001),integer($08040000),integer($08040001), + integer($09000000),integer($09000001),integer($09040000),integer($09040001), + integer($08000002),integer($08000003),integer($08040002),integer($08040003), + integer($09000002),integer($09000003),integer($09040002),integer($09040003), + integer($08000200),integer($08000201),integer($08040200),integer($08040201), + integer($09000200),integer($09000201),integer($09040200),integer($09040201), + integer($08000202),integer($08000203),integer($08040202),integer($08040203), + integer($09000202),integer($09000203),integer($09040202),integer($09040203) + ),( + (* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *) + integer($00000000),integer($00100000),integer($00000100),integer($00100100), + integer($00000008),integer($00100008),integer($00000108),integer($00100108), + integer($00001000),integer($00101000),integer($00001100),integer($00101100), + integer($00001008),integer($00101008),integer($00001108),integer($00101108), + integer($04000000),integer($04100000),integer($04000100),integer($04100100), + integer($04000008),integer($04100008),integer($04000108),integer($04100108), + integer($04001000),integer($04101000),integer($04001100),integer($04101100), + integer($04001008),integer($04101008),integer($04001108),integer($04101108), + integer($00020000),integer($00120000),integer($00020100),integer($00120100), + integer($00020008),integer($00120008),integer($00020108),integer($00120108), + integer($00021000),integer($00121000),integer($00021100),integer($00121100), + integer($00021008),integer($00121008),integer($00021108),integer($00121108), + integer($04020000),integer($04120000),integer($04020100),integer($04120100), + integer($04020008),integer($04120008),integer($04020108),integer($04120108), + integer($04021000),integer($04121000),integer($04021100),integer($04121100), + integer($04021008),integer($04121008),integer($04021108),integer($04121108) + ),( + (* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + integer($00000000),integer($10000000),integer($00010000),integer($10010000), + integer($00000004),integer($10000004),integer($00010004),integer($10010004), + integer($20000000),integer($30000000),integer($20010000),integer($30010000), + integer($20000004),integer($30000004),integer($20010004),integer($30010004), + integer($00100000),integer($10100000),integer($00110000),integer($10110000), + integer($00100004),integer($10100004),integer($00110004),integer($10110004), + integer($20100000),integer($30100000),integer($20110000),integer($30110000), + integer($20100004),integer($30100004),integer($20110004),integer($30110004), + integer($00001000),integer($10001000),integer($00011000),integer($10011000), + integer($00001004),integer($10001004),integer($00011004),integer($10011004), + integer($20001000),integer($30001000),integer($20011000),integer($30011000), + integer($20001004),integer($30001004),integer($20011004),integer($30011004), + integer($00101000),integer($10101000),integer($00111000),integer($10111000), + integer($00101004),integer($10101004),integer($00111004),integer($10111004), + integer($20101000),integer($30101000),integer($20111000),integer($30111000), + integer($20101004),integer($30101004),integer($20111004),integer($30111004) + ),( + (* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *) + integer($00000000),integer($08000000),integer($00000008),integer($08000008), + integer($00000400),integer($08000400),integer($00000408),integer($08000408), + integer($00020000),integer($08020000),integer($00020008),integer($08020008), + integer($00020400),integer($08020400),integer($00020408),integer($08020408), + integer($00000001),integer($08000001),integer($00000009),integer($08000009), + integer($00000401),integer($08000401),integer($00000409),integer($08000409), + integer($00020001),integer($08020001),integer($00020009),integer($08020009), + integer($00020401),integer($08020401),integer($00020409),integer($08020409), + integer($02000000),integer($0A000000),integer($02000008),integer($0A000008), + integer($02000400),integer($0A000400),integer($02000408),integer($0A000408), + integer($02020000),integer($0A020000),integer($02020008),integer($0A020008), + integer($02020400),integer($0A020400),integer($02020408),integer($0A020408), + integer($02000001),integer($0A000001),integer($02000009),integer($0A000009), + integer($02000401),integer($0A000401),integer($02000409),integer($0A000409), + integer($02020001),integer($0A020001),integer($02020009),integer($0A020009), + integer($02020401),integer($0A020401),integer($02020409),integer($0A020409) + ),( + (* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *) + integer($00000000),integer($00000100),integer($00080000),integer($00080100), + integer($01000000),integer($01000100),integer($01080000),integer($01080100), + integer($00000010),integer($00000110),integer($00080010),integer($00080110), + integer($01000010),integer($01000110),integer($01080010),integer($01080110), + integer($00200000),integer($00200100),integer($00280000),integer($00280100), + integer($01200000),integer($01200100),integer($01280000),integer($01280100), + integer($00200010),integer($00200110),integer($00280010),integer($00280110), + integer($01200010),integer($01200110),integer($01280010),integer($01280110), + integer($00000200),integer($00000300),integer($00080200),integer($00080300), + integer($01000200),integer($01000300),integer($01080200),integer($01080300), + integer($00000210),integer($00000310),integer($00080210),integer($00080310), + integer($01000210),integer($01000310),integer($01080210),integer($01080310), + integer($00200200),integer($00200300),integer($00280200),integer($00280300), + integer($01200200),integer($01200300),integer($01280200),integer($01280300), + integer($00200210),integer($00200310),integer($00280210),integer($00280310), + integer($01200210),integer($01200310),integer($01280210),integer($01280310) + ),( + (* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *) + integer($00000000),integer($04000000),integer($00040000),integer($04040000), + integer($00000002),integer($04000002),integer($00040002),integer($04040002), + integer($00002000),integer($04002000),integer($00042000),integer($04042000), + integer($00002002),integer($04002002),integer($00042002),integer($04042002), + integer($00000020),integer($04000020),integer($00040020),integer($04040020), + integer($00000022),integer($04000022),integer($00040022),integer($04040022), + integer($00002020),integer($04002020),integer($00042020),integer($04042020), + integer($00002022),integer($04002022),integer($00042022),integer($04042022), + integer($00000800),integer($04000800),integer($00040800),integer($04040800), + integer($00000802),integer($04000802),integer($00040802),integer($04040802), + integer($00002800),integer($04002800),integer($00042800),integer($04042800), + integer($00002802),integer($04002802),integer($00042802),integer($04042802), + integer($00000820),integer($04000820),integer($00040820),integer($04040820), + integer($00000822),integer($04000822),integer($00040822),integer($04040822), + integer($00002820),integer($04002820),integer($00042820),integer($04042820), + integer($00002822),integer($04002822),integer($00042822),integer($04042822) + )); + + des_sptrans: array[0..7,0..63] of integer=( + ( + (* nibble 0 *) + integer($02080800), integer($00080000), integer($02000002), integer($02080802), + integer($02000000), integer($00080802), integer($00080002), integer($02000002), + integer($00080802), integer($02080800), integer($02080000), integer($00000802), + integer($02000802), integer($02000000), integer($00000000), integer($00080002), + integer($00080000), integer($00000002), integer($02000800), integer($00080800), + integer($02080802), integer($02080000), integer($00000802), integer($02000800), + integer($00000002), integer($00000800), integer($00080800), integer($02080002), + integer($00000800), integer($02000802), integer($02080002), integer($00000000), + integer($00000000), integer($02080802), integer($02000800), integer($00080002), + integer($02080800), integer($00080000), integer($00000802), integer($02000800), + integer($02080002), integer($00000800), integer($00080800), integer($02000002), + integer($00080802), integer($00000002), integer($02000002), integer($02080000), + integer($02080802), integer($00080800), integer($02080000), integer($02000802), + integer($02000000), integer($00000802), integer($00080002), integer($00000000), + integer($00080000), integer($02000000), integer($02000802), integer($02080800), + integer($00000002), integer($02080002), integer($00000800), integer($00080802) + ),( + (* nibble 1 *) + integer($40108010), integer($00000000), integer($00108000), integer($40100000), + integer($40000010), integer($00008010), integer($40008000), integer($00108000), + integer($00008000), integer($40100010), integer($00000010), integer($40008000), + integer($00100010), integer($40108000), integer($40100000), integer($00000010), + integer($00100000), integer($40008010), integer($40100010), integer($00008000), + integer($00108010), integer($40000000), integer($00000000), integer($00100010), + integer($40008010), integer($00108010), integer($40108000), integer($40000010), + integer($40000000), integer($00100000), integer($00008010), integer($40108010), + integer($00100010), integer($40108000), integer($40008000), integer($00108010), + integer($40108010), integer($00100010), integer($40000010), integer($00000000), + integer($40000000), integer($00008010), integer($00100000), integer($40100010), + integer($00008000), integer($40000000), integer($00108010), integer($40008010), + integer($40108000), integer($00008000), integer($00000000), integer($40000010), + integer($00000010), integer($40108010), integer($00108000), integer($40100000), + integer($40100010), integer($00100000), integer($00008010), integer($40008000), + integer($40008010), integer($00000010), integer($40100000), integer($00108000) + ),( + (* nibble 2 *) + integer($04000001), integer($04040100), integer($00000100), integer($04000101), + integer($00040001), integer($04000000), integer($04000101), integer($00040100), + integer($04000100), integer($00040000), integer($04040000), integer($00000001), + integer($04040101), integer($00000101), integer($00000001), integer($04040001), + integer($00000000), integer($00040001), integer($04040100), integer($00000100), + integer($00000101), integer($04040101), integer($00040000), integer($04000001), + integer($04040001), integer($04000100), integer($00040101), integer($04040000), + integer($00040100), integer($00000000), integer($04000000), integer($00040101), + integer($04040100), integer($00000100), integer($00000001), integer($00040000), + integer($00000101), integer($00040001), integer($04040000), integer($04000101), + integer($00000000), integer($04040100), integer($00040100), integer($04040001), + integer($00040001), integer($04000000), integer($04040101), integer($00000001), + integer($00040101), integer($04000001), integer($04000000), integer($04040101), + integer($00040000), integer($04000100), integer($04000101), integer($00040100), + integer($04000100), integer($00000000), integer($04040001), integer($00000101), + integer($04000001), integer($00040101), integer($00000100), integer($04040000) + ),( + (* nibble 3 *) + integer($00401008), integer($10001000), integer($00000008), integer($10401008), + integer($00000000), integer($10400000), integer($10001008), integer($00400008), + integer($10401000), integer($10000008), integer($10000000), integer($00001008), + integer($10000008), integer($00401008), integer($00400000), integer($10000000), + integer($10400008), integer($00401000), integer($00001000), integer($00000008), + integer($00401000), integer($10001008), integer($10400000), integer($00001000), + integer($00001008), integer($00000000), integer($00400008), integer($10401000), + integer($10001000), integer($10400008), integer($10401008), integer($00400000), + integer($10400008), integer($00001008), integer($00400000), integer($10000008), + integer($00401000), integer($10001000), integer($00000008), integer($10400000), + integer($10001008), integer($00000000), integer($00001000), integer($00400008), + integer($00000000), integer($10400008), integer($10401000), integer($00001000), + integer($10000000), integer($10401008), integer($00401008), integer($00400000), + integer($10401008), integer($00000008), integer($10001000), integer($00401008), + integer($00400008), integer($00401000), integer($10400000), integer($10001008), + integer($00001008), integer($10000000), integer($10000008), integer($10401000) + ),( + (* nibble 4 *) + integer($08000000), integer($00010000), integer($00000400), integer($08010420), + integer($08010020), integer($08000400), integer($00010420), integer($08010000), + integer($00010000), integer($00000020), integer($08000020), integer($00010400), + integer($08000420), integer($08010020), integer($08010400), integer($00000000), + integer($00010400), integer($08000000), integer($00010020), integer($00000420), + integer($08000400), integer($00010420), integer($00000000), integer($08000020), + integer($00000020), integer($08000420), integer($08010420), integer($00010020), + integer($08010000), integer($00000400), integer($00000420), integer($08010400), + integer($08010400), integer($08000420), integer($00010020), integer($08010000), + integer($00010000), integer($00000020), integer($08000020), integer($08000400), + integer($08000000), integer($00010400), integer($08010420), integer($00000000), + integer($00010420), integer($08000000), integer($00000400), integer($00010020), + integer($08000420), integer($00000400), integer($00000000), integer($08010420), + integer($08010020), integer($08010400), integer($00000420), integer($00010000), + integer($00010400), integer($08010020), integer($08000400), integer($00000420), + integer($00000020), integer($00010420), integer($08010000), integer($08000020) + ),( + (* nibble 5 *) + integer($80000040), integer($00200040), integer($00000000), integer($80202000), + integer($00200040), integer($00002000), integer($80002040), integer($00200000), + integer($00002040), integer($80202040), integer($00202000), integer($80000000), + integer($80002000), integer($80000040), integer($80200000), integer($00202040), + integer($00200000), integer($80002040), integer($80200040), integer($00000000), + integer($00002000), integer($00000040), integer($80202000), integer($80200040), + integer($80202040), integer($80200000), integer($80000000), integer($00002040), + integer($00000040), integer($00202000), integer($00202040), integer($80002000), + integer($00002040), integer($80000000), integer($80002000), integer($00202040), + integer($80202000), integer($00200040), integer($00000000), integer($80002000), + integer($80000000), integer($00002000), integer($80200040), integer($00200000), + integer($00200040), integer($80202040), integer($00202000), integer($00000040), + integer($80202040), integer($00202000), integer($00200000), integer($80002040), + integer($80000040), integer($80200000), integer($00202040), integer($00000000), + integer($00002000), integer($80000040), integer($80002040), integer($80202000), + integer($80200000), integer($00002040), integer($00000040), integer($80200040) + ),( + (* nibble 6 *) + integer($00004000), integer($00000200), integer($01000200), integer($01000004), + integer($01004204), integer($00004004), integer($00004200), integer($00000000), + integer($01000000), integer($01000204), integer($00000204), integer($01004000), + integer($00000004), integer($01004200), integer($01004000), integer($00000204), + integer($01000204), integer($00004000), integer($00004004), integer($01004204), + integer($00000000), integer($01000200), integer($01000004), integer($00004200), + integer($01004004), integer($00004204), integer($01004200), integer($00000004), + integer($00004204), integer($01004004), integer($00000200), integer($01000000), + integer($00004204), integer($01004000), integer($01004004), integer($00000204), + integer($00004000), integer($00000200), integer($01000000), integer($01004004), + integer($01000204), integer($00004204), integer($00004200), integer($00000000), + integer($00000200), integer($01000004), integer($00000004), integer($01000200), + integer($00000000), integer($01000204), integer($01000200), integer($00004200), + integer($00000204), integer($00004000), integer($01004204), integer($01000000), + integer($01004200), integer($00000004), integer($00004004), integer($01004204), + integer($01000004), integer($01004200), integer($01004000), integer($00004004) + ),( + (* nibble 7 *) + integer($20800080), integer($20820000), integer($00020080), integer($00000000), + integer($20020000), integer($00800080), integer($20800000), integer($20820080), + integer($00000080), integer($20000000), integer($00820000), integer($00020080), + integer($00820080), integer($20020080), integer($20000080), integer($20800000), + integer($00020000), integer($00820080), integer($00800080), integer($20020000), + integer($20820080), integer($20000080), integer($00000000), integer($00820000), + integer($20000000), integer($00800000), integer($20020080), integer($20800080), + integer($00800000), integer($00020000), integer($20820000), integer($00000080), + integer($00800000), integer($00020000), integer($20000080), integer($20820080), + integer($00020080), integer($20000000), integer($00000000), integer($00820000), + integer($20800080), integer($20020080), integer($20020000), integer($00800080), + integer($20820000), integer($00000080), integer($00800080), integer($20020000), + integer($20820080), integer($00800000), integer($20800000), integer($20000080), + integer($00820000), integer($00020080), integer($20020080), integer($20800000), + integer($00000080), integer($20820000), integer($00820080), integer($00000000), + integer($20000000), integer($20800080), integer($00020000), integer($00820080) + )); + +{==============================================================================} + +function XorString(Indata1, Indata2: AnsiString): AnsiString; +var + i: integer; +begin + Indata2 := PadString(Indata2, length(Indata1), #0); + Result := ''; + for i := 1 to length(Indata1) do + Result := Result + AnsiChar(ord(Indata1[i]) xor ord(Indata2[i])); +end; + +procedure hperm_op(var a, t: integer; n, m: integer); +begin + t:= ((a shl (16 - n)) xor a) and m; + a:= a xor t xor (t shr (16 - n)); +end; + +procedure perm_op(var a, b, t: integer; n, m: integer); +begin + t:= ((a shr n) xor b) and m; + b:= b xor t; + a:= a xor (t shl n); +end; + +{==============================================================================} +procedure TSynaBlockCipher.IncCounter; +var + i: integer; +begin + Inc(CV[8]); + i:= 7; + while (i> 0) and (CV[i + 1] = #0) do + begin + Inc(CV[i]); + Dec(i); + end; +end; + +procedure TSynaBlockCipher.Reset; +begin + CV := IV; +end; + +procedure TSynaBlockCipher.InitKey(Key: AnsiString); +begin +end; + +procedure TSynaBlockCipher.SetIV(const Value: AnsiString); +begin + IV := PadString(Value, 8, #0); + Reset; +end; + +function TSynaBlockCipher.GetIV: AnsiString; +begin + Result := CV; +end; + +function TSynaBlockCipher.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := InData; +end; + +function TSynaBlockCipher.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := InData; +end; + +function TSynaBlockCipher.EncryptCBC(const Indata: AnsiString): AnsiString; +var + i: integer; + s: ansistring; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + s := copy(Indata, (i - 1) * 8 + 1, 8); + s := XorString(s, CV); + s := EncryptECB(s); + CV := s; + Result := Result + s; + end; + if (l mod 8)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCBC(const Indata: AnsiString): AnsiString; +var + i: integer; + s, temp: ansistring; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + s := copy(Indata, (i - 1) * 8 + 1, 8); + temp := s; + s := DecryptECB(s); + s := XorString(s, CV); + Result := Result + s; + CV := Temp; + end; + if (l mod 8)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptCFB8bit(const Indata: AnsiString): AnsiString; +var + i: integer; + Temp: AnsiString; + c: AnsiChar; +begin + Result := ''; + for i:= 1 to Length(Indata) do + begin + Temp := EncryptECB(CV); + c := AnsiChar(ord(InData[i]) xor ord(temp[1])); + Result := Result + c; + Delete(CV, 1, 1); + CV := CV + c; + end; +end; + +function TSynaBlockCipher.DecryptCFB8bit(const Indata: AnsiString): AnsiString; +var + i: integer; + Temp: AnsiString; + c: AnsiChar; +begin + Result := ''; + for i:= 1 to length(Indata) do + begin + c:= Indata[i]; + Temp := EncryptECB(CV); + Result := Result + AnsiChar(ord(InData[i]) xor ord(temp[1])); + Delete(CV, 1, 1); + CV := CV + c; + end; +end; + +function TSynaBlockCipher.EncryptCFBblock(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + CV := EncryptECB(CV); + s := copy(Indata, (i - 1) * 8 + 1, 8); + s := XorString(s, CV); + Result := Result + s; + CV := s; + end; + if (l mod 8)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCFBblock(const Indata: AnsiString): AnsiString; +var + i: integer; + S, Temp: AnsiString; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + s := copy(Indata, (i - 1) * 8 + 1, 8); + Temp := s; + CV := EncryptECB(CV); + s := XorString(s, CV); + Result := result + s; + CV := temp; + end; + if (l mod 8)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptOFB(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + CV := EncryptECB(CV); + s := copy(Indata, (i - 1) * 8 + 1, 8); + s := XorString(s, CV); + Result := Result + s; + end; + if (l mod 8)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptOFB(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + Cv := EncryptECB(CV); + s := copy(Indata, (i - 1) * 8 + 1, 8); + s := XorString(s, CV); + Result := Result + s; + end; + if (l mod 8)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptCTR(const Indata: AnsiString): AnsiString; +var + temp: AnsiString; + i: integer; + s: AnsiString; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (i - 1) * 8 + 1, 8); + s := XorString(s, temp); + Result := Result + s; + end; + if (l mod 8)<> 0 then + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, temp); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCTR(const Indata: AnsiString): AnsiString; +var + temp: AnsiString; + s: AnsiString; + i: integer; + l: integer; +begin + Result := ''; + l := Length(InData); + for i:= 1 to (l div 8) do + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (i - 1) * 8 + 1, 8); + s := XorString(s, temp); + Result := Result + s; + end; + if (l mod 8)<> 0 then + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (l div 8) * 8 + 1, l mod 8); + s := XorString(s, temp); + Result := Result + s; + end; +end; + +constructor TSynaBlockCipher.Create(Key: AnsiString); +begin + inherited Create; + InitKey(Key); + IV := StringOfChar(#0, 8); + IV := EncryptECB(IV); + Reset; +end; + +{==============================================================================} + +procedure TSynaCustomDes.DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); +var + c, d, t, s, t2, i: integer; +begin + KeyB := PadString(KeyB, 8, #0); + c:= ord(KeyB[1]) or (ord(KeyB[2]) shl 8) or (ord(KeyB[3]) shl 16) or (ord(KeyB[4]) shl 24); + d:= ord(KeyB[5]) or (ord(KeyB[6]) shl 8) or (ord(KeyB[7]) shl 16) or (ord(KeyB[8]) shl 24); + perm_op(d,c,t,4,integer($0f0f0f0f)); + hperm_op(c,t,integer(-2),integer($cccc0000)); + hperm_op(d,t,integer(-2),integer($cccc0000)); + perm_op(d,c,t,1,integer($55555555)); + perm_op(c,d,t,8,integer($00ff00ff)); + perm_op(d,c,t,1,integer($55555555)); + d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or + ((c and integer($f0000000)) shr 4); + c:= c and $fffffff; + for i:= 0 to 15 do + begin + if shifts2[i]<> 0 then + begin + c:= ((c shr 2) or (c shl 26)); + d:= ((d shr 2) or (d shl 26)); + end + else + begin + c:= ((c shr 1) or (c shl 27)); + d:= ((d shr 1) or (d shl 27)); + end; + c:= c and $fffffff; + d:= d and $fffffff; + s:= des_skb[0,c and $3f] or + des_skb[1,((c shr 6) and $03) or ((c shr 7) and $3c)] or + des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or + des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)]; + t:= des_skb[4,d and $3f] or + des_skb[5,((d shr 7) and $03) or ((d shr 8) and $3c)] or + des_skb[6, (d shr 15) and $3f ] or + des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)]; + t2:= ((t shl 16) or (s and $ffff)); + KeyData[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30)); + t2:= ((s shr 16) or (t and integer($ffff0000))); + KeyData[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26)); + end; +end; + +function TSynaCustomDes.EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; +var + l, r, t, u: integer; + i: longint; +begin + r := Swapbytes(DecodeLongint(Indata, 1)); + l := swapbytes(DecodeLongint(Indata, 5)); + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 0; + while i< 32 do + begin + u:= r xor KeyData[i ]; + t:= r xor KeyData[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i+2]; + t:= l xor KeyData[i+3]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData[i+4]; + t:= r xor KeyData[i+5]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i+6]; + t:= l xor KeyData[i+7]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Inc(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); +end; + +function TSynaCustomDes.DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; +var + l, r, t, u: integer; + i: longint; +begin + r := Swapbytes(DecodeLongint(Indata, 1)); + l := Swapbytes(DecodeLongint(Indata, 5)); + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 30; + while i> 0 do + begin + u:= r xor KeyData[i ]; + t:= r xor KeyData[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i-2]; + t:= l xor KeyData[i-1]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData[i-4]; + t:= r xor KeyData[i-3]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i-6]; + t:= l xor KeyData[i-5]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Dec(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); +end; + +{==============================================================================} + +procedure TSynaDes.InitKey(Key: AnsiString); +begin + Key := PadString(Key, 8, #0); + DoInit(Key,KeyData); +end; + +function TSynaDes.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := EncryptBlock(InData,KeyData); +end; + +function TSynaDes.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := DecryptBlock(Indata,KeyData); +end; + +{==============================================================================} + +procedure TSyna3Des.InitKey(Key: AnsiString); +var + Size: integer; + n: integer; +begin + Size := length(Key); + key := PadString(key, 3 * 8, #0); + DoInit(Copy(key, 1, 8),KeyData[0]); + DoInit(Copy(key, 9, 8),KeyData[1]); + if Size > 16 then + DoInit(Copy(key, 17, 8),KeyData[2]) + else + for n := 0 to high(KeyData[0]) do + KeyData[2][n] := Keydata[0][n]; +end; + +function TSyna3Des.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := EncryptBlock(Indata,KeyData[0]); + Result := DecryptBlock(Result,KeyData[1]); + Result := EncryptBlock(Result,KeyData[2]); +end; + +function TSyna3Des.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := DecryptBlock(InData,KeyData[2]); + Result := EncryptBlock(Result,KeyData[1]); + Result := DecryptBlock(Result,KeyData[0]); +end; + +{==============================================================================} + +function TestDes: boolean; +var + des: TSynaDes; + s, t: string; +const + key = '01234567'; + data1= '01234567'; + data2= '0123456789abcdefghij'; +begin + //ECB + des := TSynaDes.Create(key); + try + s := des.EncryptECB(data1); + t := strtohex(s); + result := t = 'c50ad028c6da9800'; + s := des.DecryptECB(s); + result := result and (data1 = s); + finally + des.free; + end; + //CBC + des := TSynaDes.Create(key); + try + s := des.EncryptCBC(data2); + t := strtohex(s); + result := result and (t = 'eec50f6353115ad6dee90a22ed1b6a88a0926e35'); + des.Reset; + s := des.DecryptCBC(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-8bit + des := TSynaDes.Create(key); + try + s := des.EncryptCFB8bit(data2); + t := strtohex(s); + result := result and (t = 'eb6aa12c2f0ff634b4dfb6da6cb2af8f9c5c1452'); + des.Reset; + s := des.DecryptCFB8bit(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-block + des := TSynaDes.Create(key); + try + s := des.EncryptCFBblock(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cdec28605e07f9b7f3be1053257'); + des.Reset; + s := des.DecryptCFBblock(s); + result := result and (data2 = s); + finally + des.free; + end; + //OFB + des := TSynaDes.Create(key); + try + s := des.EncryptOFB(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cdee0b8b3798c4c34baac87dbdc'); + des.Reset; + s := des.DecryptOFB(s); + result := result and (data2 = s); + finally + des.free; + end; + //CTR + des := TSynaDes.Create(key); + try + s := des.EncryptCTR(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cde0dd20b45f3afd9aa1b91b87e'); + des.Reset; + s := des.DecryptCTR(s); + result := result and (data2 = s); + finally + des.free; + end; +end; + +function Test3Des: boolean; +var + des: TSyna3Des; + s, t: string; +const + key = '0123456789abcdefghijklmn'; + data1= '01234567'; + data2= '0123456789abcdefghij'; +begin + //ECB + des := TSyna3Des.Create(key); + try + s := des.EncryptECB(data1); + t := strtohex(s); + result := t = 'e0dee91008dc460c'; + s := des.DecryptECB(s); + result := result and (data1 = s); + finally + des.free; + end; + //CBC + des := TSyna3Des.Create(key); + try + s := des.EncryptCBC(data2); + t := strtohex(s); + result := result and (t = 'ee844a2a4f49c01b91a1599b8eba29128c1ad87a'); + des.Reset; + s := des.DecryptCBC(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-8bit + des := TSyna3Des.Create(key); + try + s := des.EncryptCFB8bit(data2); + t := strtohex(s); + result := result and (t = '935bbf5210c32cfa1faf61f91e8dc02dfa0ff1e8'); + des.Reset; + s := des.DecryptCFB8bit(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-block + des := TSyna3Des.Create(key); + try + s := des.EncryptCFBblock(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf4bd81f1739419e8d2cfe1671'); + des.Reset; + s := des.DecryptCFBblock(s); + result := result and (data2 = s); + finally + des.free; + end; + //OFB + des := TSyna3Des.Create(key); + try + s := des.EncryptOFB(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf04ef0a5efc926ebdf2d95f20'); + des.Reset; + s := des.DecryptOFB(s); + result := result and (data2 = s); + finally + des.free; + end; + //CTR + des := TSyna3Des.Create(key); + try + s := des.EncryptCTR(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf1c51a121d2c93f989e70b3ad'); + des.Reset; + s := des.DecryptCTR(s); + result := result and (data2 = s); + finally + des.free; + end; +end; + +{==============================================================================} + +end. diff --git a/synafpc.pas b/synafpc.pas index 0370d5e..a3d580b 100644 --- a/synafpc.pas +++ b/synafpc.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.000 | +| Project : Ararat Synapse | 001.001.001 | |==============================================================================| | Content: Utils for FreePascal compatibility | |==============================================================================| -| Copyright (c)1999-2006, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003-2006. | +| Portions created by Lukas Gebauer are Copyright (c)2003-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -60,7 +60,7 @@ uses {$IFDEF WIN32} Windows; {$ELSE} - Sysutils; + SysUtils; {$ENDIF} {$ENDIF} diff --git a/synaicnv.pas b/synaicnv.pas index 72a0623..cc36046 100644 --- a/synaicnv.pas +++ b/synaicnv.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.001 | +| Project : Ararat Synapse | 001.000.002 | |==============================================================================| | Content: ICONV support for Win32, Linux and .NET | |==============================================================================| @@ -64,7 +64,10 @@ uses {$ENDIF} synafpc, {$IFNDEF WIN32} - Libc, SysUtils; + {$IFNDEF FPC} + Libc, + {$ENDIF} + SysUtils; {$ELSE} Windows; {$ENDIF} diff --git a/synaip.pas b/synaip.pas index 9d93c9c..f365a6f 100644 --- a/synaip.pas +++ b/synaip.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.000 | +| Project : Ararat Synapse | 001.000.002 | |==============================================================================| | Content: IP address support procedures and functions | |==============================================================================| @@ -218,8 +218,8 @@ var y1, y2: byte; begin Result := ''; - x1 := value div $10000; - x2 := value mod $10000; + x1 := value shr 16; + x2 := value and $FFFF; y1 := x1 div $100; y2 := x1 mod $100; Result := inttostr(y1) + '.' + inttostr(y2) + '.'; @@ -379,11 +379,18 @@ function ReverseIP6(Value: AnsiString): AnsiString; var ip6: TIp6bytes; n: integer; + x, y: integer; begin ip6 := StrToIP6(Value); - Result := char(ip6[15]); + x := ip6[15] div 16; + y := ip6[15] mod 16; + Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); for n := 14 downto 0 do - Result := Result + '.' + char(ip6[n]); + begin + x := ip6[n] div 16; + y := ip6[n] mod 16; + Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); + end; end; {==============================================================================} diff --git a/synautil.pas b/synautil.pas index 863fc2f..dfa970d 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 004.010.001 | +| Project : Ararat Synapse | 004.011.003 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| @@ -302,6 +302,10 @@ procedure WriteStrToStream(const Stream: TStream; Value: AnsiString); directory is used) and with optional filename prefix.} function GetTempFile(const Dir, prefix: AnsiString): AnsiString; +{:Return padded string. If length is greater, string is truncated. If length is + smaller, string is padded by Pad character.} +function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; + var {:can be used for your own months strings for @link(getmonthnumber)} CustomMonthNames: array[1..12] of string; @@ -664,10 +668,15 @@ begin end; if year = 0 then year := 1980; - if (month < 1) or (month > 12) then + if month < 1 then month := 1; - if (day < 1) or (day > 31) then + if month > 12 then + month := 12; + if day < 1 then day := 1; + x := MonthDays[IsLeapYear(year), month]; + if day > x then + day := x; Result := Result + Encodedate(year, month, day); zone := zone - TimeZoneBias; x := zone div 1440; @@ -1394,10 +1403,12 @@ begin Result := False; for n := 1 to Length(Value) do if Value[n] in [#0..#8, #10..#31] then - begin - Result := True; - Break; - end; + //ignore null-terminated strings + if not ((n = Length(value)) and (Value[n] = #0)) then + begin + Result := True; + Break; + end; end; {==============================================================================} @@ -1736,6 +1747,16 @@ begin {$ENDIF} end; +{==============================================================================} + +function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; +begin + if length(value) >= len then + Result := Copy(value, 1, len) + else + Result := Value + StringOfChar(Pad, len - length(value)); +end; + {==============================================================================} var n: integer; diff --git a/tlntsend.pas b/tlntsend.pas index 3d18a33..002ab0f 100644 --- a/tlntsend.pas +++ b/tlntsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.002.000 | +| Project : Ararat Synapse | 001.002.001 | |==============================================================================| | Content: TELNET and SSH2 client | |==============================================================================| -| Copyright (c)1999-2004, Lukas Gebauer | +| Copyright (c)1999-2007, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2002-2005. | +| Portions created by Lukas Gebauer are Copyright (c)2002-2007. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -61,7 +61,7 @@ uses blcksock, synautil; const - cTelnetProtocol = 'telnet'; + cTelnetProtocol = '23'; cSSHProtocol = '22'; TLNT_EOR = #239;