diff --git a/Libraries/SimpleServer/dwsICMP.pas b/Libraries/SimpleServer/dwsICMP.pas new file mode 100644 index 00000000..46d58e35 --- /dev/null +++ b/Libraries/SimpleServer/dwsICMP.pas @@ -0,0 +1,94 @@ +{**********************************************************************} +{ } +{ "The contents of this file are subject to the Mozilla Public } +{ License Version 1.1 (the "License"); you may not use this } +{ file except in compliance with the License. You may obtain } +{ a copy of the License at http://www.mozilla.org/MPL/ } +{ } +{ Software distributed under the License is distributed on an } +{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express } +{ or implied. See the License for the specific language } +{ governing rights and limitations under the License. } +{ } +{ Copyright Creative IT. } +{ Current maintainer: Eric Grange } +{ } +{**********************************************************************} +unit dwsICMP; + +interface + +function PingIPv4(const hostName : String; timeoutMs : Integer) : Integer; + +implementation + +uses Windows, SysUtils, WinSock, dwsXPlatform, dwsRandom; + +function IcmpCreateFile: THandle; stdcall; external 'iphlpapi.dll'; +function IcmpCloseHandle(icmpHandle : THandle) : Boolean; stdcall; external 'iphlpapi.dll'; +function IcmpSendEcho( + icmpHandle : THandle; destinationAddress : In_Addr; + requestData : Pointer; requestSize : SmallInt; requestOptions : Pointer; + replyBuffer : Pointer; replySize : DWORD; timeout : DWORD + ): DWORD; stdcall; external 'iphlpapi.dll'; + +type + TEchoReply = packed record + Addr : In_Addr; + Status : DWORD; + RoundTripTime : DWORD; + end; + PEchoReply = ^TEchoReply; + +var + vMessageInt64 : UInt64; + +function PingIPv4(const hostName : String; timeoutMs : Integer) : Integer; +var + e : PHostEnt; + a : PInAddr; + h : THandle; + d : UInt64; + r : array [0 .. $400 - 1] of Byte; + i : Cardinal; + hostNameA : RawByteString; +begin + if timeoutMs <= 0 then + raise Exception.Create('Timeout should be greater than zero'); + + hostNameA := UTF8Encode(hostName); + e := gethostbyname(PAnsiChar(hostNameA)); + if e = nil then + RaiseLastOSError; + if e.h_addrtype = AF_INET then + Pointer(a) := e.h_addr^ + else raise Exception.CreateFmt('Could not resolve "%" to an IPv4 address', [ hostName ]); + + d := InterlockedIncrement64(Int64(vMessageInt64)); + d := SplitMix64(d); + + h := IcmpCreateFile; + if h = INVALID_HANDLE_VALUE then + RaiseLastOSError; + try + i := IcmpSendEcho(h, a^, @d, SizeOf(d), nil, @r[0], SizeOf(r), timeoutMs); + if (i <> 0) and (PEchoReply(@r[0]).Status = 0) then + Result := PEchoReply(@r[0]).RoundTripTime + else Result := -1; + finally + IcmpCloseHandle(h); + end; +end; + +// ------------------------------------------------------------------ +// ------------------------------------------------------------------ +// ------------------------------------------------------------------ +initialization +// ------------------------------------------------------------------ +// ------------------------------------------------------------------ +// ------------------------------------------------------------------ + + vMessageInt64 := GetTickCount64 xor RDTSC xor GetCurrentProcessId; + vMessageInt64 := SplitMix64(vMessageInt64); + +end. diff --git a/Libraries/SimpleServer/dwsWebLibModule.dfm b/Libraries/SimpleServer/dwsWebLibModule.dfm index 5bb4addd..04b061a3 100644 --- a/Libraries/SimpleServer/dwsWebLibModule.dfm +++ b/Libraries/SimpleServer/dwsWebLibModule.dfm @@ -1128,6 +1128,20 @@ object dwsWebLib: TdwsWebLib end> ResultType = 'String' OnEval = dwsWebFunctionsGetHostByNameEval + end + item + Name = 'PingIPv4' + Parameters = < + item + Name = 'hostName' + DataType = 'String' + end + item + Name = 'timeOutMSec' + DataType = 'Integer' + end> + ResultType = 'Integer' + OnFastEval = dwsWebFunctionsPingIPv4FastEval end> UnitName = 'System.Net' StaticSymbols = True diff --git a/Libraries/SimpleServer/dwsWebLibModule.pas b/Libraries/SimpleServer/dwsWebLibModule.pas index 3a00ade2..96009ed7 100644 --- a/Libraries/SimpleServer/dwsWebLibModule.pas +++ b/Libraries/SimpleServer/dwsWebLibModule.pas @@ -192,6 +192,8 @@ TdwsWebLib = class(TDataModule) Info: TProgramInfo; ExtObject: TObject); procedure dwsWebClassesWebRequestMethodsContentFieldsEval( Info: TProgramInfo; ExtObject: TObject); + function dwsWebFunctionsPingIPv4FastEval( + const args: TExprBaseListExec): Variant; private { Private declarations } FServer : IWebServerInfo; @@ -204,7 +206,7 @@ implementation {$R *.dfm} -uses dwsWinHTTP, dwsDynamicArrays; +uses dwsWinHTTP, dwsDynamicArrays, dwsICMP; // WebServerSentEventToRawData // @@ -1175,6 +1177,12 @@ procedure TdwsWebLib.dwsWebFunctionsGetHostByNameEval(info: TProgramInfo); else info.ResultAsDataString := ResolveName(host); end; +function TdwsWebLib.dwsWebFunctionsPingIPv4FastEval( + const args: TExprBaseListExec): Variant; +begin + Result := PingIPv4(args.AsString[0], args.AsInteger[1]); +end; + procedure TdwsWebLib.dwsWebClassesHttpRequestCleanUp(ExternalObject: TObject); var t : THttpRequestThread;