Added PingIPv4 function

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.

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

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;