unit TGPSvcDiscoverUDP;


interface

uses
  SysUtils, Classes, FMX.Controls,
  IdBaseComponent, IdComponent, IdIPMCastBase, IdIPMCastServer, IdIPMCastClient,
  IdStack, IdSocketHandle,
  IdGlobal,
  System.Generics.Collections, System.Threading;

type
  TTGPServiceDiscoveryUDPServer = class(TComponent)
  private
    { Private declarations }
    FIdIPMCastServerList: TList<TIdIPMCastServer>;
    FLocalIPs: TIdStackLocalAddressList;
    FMulticastGroup: String;
    FGroup: String;
    // ALE 20150906 The multicast group/address narrows the traffic, the Group
    // narrows it further to a topic of discussion.
    FActive: Boolean;
    FPort: Cardinal; // ALE 20150906 Actual port that was successfully opened
    FPortLow: Cardinal; // ALE 20150906 First port to try
    FPortHigh: Cardinal; // ALE 20150906 Last port to try
  protected
    { Protected declarations }
    procedure Activate(pActive: Boolean);
  public
    constructor Create(AOwner: TComponent); override; { Main Constructor }
    destructor Destroy; override; { Main Destructor }
    procedure Send(const AData: string; AByteEncoding: IIdTextEncoding = nil
{$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF});
  published
    { Published declarations }
    property Active: Boolean read FActive write Activate;
    property Port: Cardinal read FPort;
    property PortLow: Cardinal read FPortLow write FPortLow;
    property PortHigh: Cardinal read FPortHigh write FPortHigh;
    property Group: String read FGroup write FGroup;
    property GroupAddress: String read FMulticastGroup write FMulticastGroup;
  end;

  TTGPServiceDiscoveryUDPClient = class(TComponent)
  private
    { Private declarations }
    FIdIPMCastClientList: TList<TIdIPMCastClient>;
    FLocalIPs: TIdStackLocalAddressList;
    FMulticastGroup: String;
    FGroup: String;
    // ALE 20150906 The multicast group/address narrows the traffic, the Group
    // narrows it further to a topic of discussion.
    FActive: Boolean;
    FPort: Cardinal; // ALE 20150906 Actual port that was successfully opened
    FPortLow: Cardinal; // ALE 20150906 First port to try
    FPortHigh: Cardinal; // ALE 20150906 Last port to try
  protected
    { Protected declarations }
    procedure Activate(pActive: Boolean);
  public
    FOnIPMCastRead: TIPMCastReadEvent;
    constructor Create(AOwner: TComponent); override; { Main Constructor }
    destructor Destroy; override; { Main Destructor }
    procedure IPMCastRead(Sender: TObject; const AData: TIdBytes;
      ABinding: TIdSocketHandle);
  published
    { Published declarations }
    property Active: Boolean read FActive write Activate;
    property Port: Cardinal read FPort;
    property PortLow: Cardinal read FPortLow write FPortLow;
    property PortHigh: Cardinal read FPortHigh write FPortHigh;
    property Group: String read FGroup write FGroup;
    property GroupAddress: String read FMulticastGroup write FMulticastGroup;
    property OnIPMCastRead: TIPMCastReadEvent read FOnIPMCastRead
      write FOnIPMCastRead;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('TGP', [TTGPServiceDiscoveryUDPServer,
    TTGPServiceDiscoveryUDPClient]);
end;

{ TTGPServiceDiscoveryUDPServer }
procedure TTGPServiceDiscoveryUDPServer.Activate(pActive: Boolean);
var
  lIdIPMCastServer: TIdIPMCastServer;
  lPort: Cardinal;
  lActive: Boolean;
begin
  if (pActive = False) then
  begin
    for lIdIPMCastServer in FIdIPMCastServerList do
    begin
      lIdIPMCastServer.Active := False;
    end;
  end
  else
  begin // ALE 20150908 try to activate the multicast server
    FPort := 0;
    lActive := True;
    for lPort := FPortLow to FPortHigh do
    begin
      for lIdIPMCastServer in FIdIPMCastServerList do
      begin
        lIdIPMCastServer.Port := lPort;
        lIdIPMCastServer.MulticastGroup := FMulticastGroup;
        try
          lIdIPMCastServer.Active := True;
        except
          lActive := False;
        end;
      end;
      if (lActive = True) then
      begin
        FPort := lPort;
        FActive := lActive;
        break;
      end;
    end;
  end;

end;

constructor TTGPServiceDiscoveryUDPServer.Create(AOwner: TComponent);
var
  lI: NativeInt;
begin
  inherited;

  FActive := False;
  FPort := 0;
  FPortLow := 45353;
  FPortHigh := 45362;
  FGroup := 'TGP';
  FMulticastGroup := '224.239.1.20';

  FLocalIPs := TIdStackLocalAddressList.Create;

  FIdIPMCastServerList := TList<TIdIPMCastServer>.Create;
  // ALE 20150903 tinker with listing local IPs for binding
  TIdStack.IncUsage;
  try
    GStack.GetLocalAddressList(FLocalIPs);
  finally
    TIdStack.DecUsage;
  end;
  for lI := FLocalIPs.Count - 1 downto 0 do
  begin
    if (FLocalIPs.Addresses[lI].IPVersion <> TIdIPVersion.Id_IPv4) then
    begin
      FLocalIPs.Delete(lI);
    end;
  end;

  // ALE 20150906 build a CastServer for each IP on the system
  for lI := 0 to FLocalIPs.Count - 1 do
  begin
    FIdIPMCastServerList.Add(TIdIPMCastServer.Create(nil));
    FIdIPMCastServerList[FIdIPMCastServerList.Count - 1].IPVersion :=
      FLocalIPs[lI].IPVersion;
    FIdIPMCastServerList[FIdIPMCastServerList.Count - 1].BoundIP :=
      FLocalIPs[lI].IPAddress;
    FIdIPMCastServerList[FIdIPMCastServerList.Count - 1].MulticastGroup :=
      FMulticastGroup;
    // FIdIPMCastServerList[FIdIPMCastServerList.Count - 1].BoundPort := FPort;
    FIdIPMCastServerList[FIdIPMCastServerList.Count - 1].Port := FPort;
    FIdIPMCastServerList[FIdIPMCastServerList.Count - 1].ReuseSocket :=
      TIdReuseSocket.rsTrue;
  end;
end;

destructor TTGPServiceDiscoveryUDPServer.Destroy;
begin
  FLocalIPs.Destroy;
  FIdIPMCastServerList.Destroy;

  inherited;
end;

procedure TTGPServiceDiscoveryUDPServer.Send(const AData: string;

  AByteEncoding: IIdTextEncoding);
var
  lI: NativeInt;
begin
  for lI := 0 to FIdIPMCastServerList.Count - 1 do
  begin
    FIdIPMCastServerList[lI]
      .Send(FGroup + FormatDateTime(',yyyy-mm-dd hh:nn:ss,', Now()) + AData);
  end;
  { ALE 20150909 this hangs the GE
    TParallel.For(0, FIdIPMCastServerList.Count - 1, procedure (lI: Integer)
    begin
    FIdIPMCastServerList[lI].Send(FGroup + FormatDateTime(',yyyy-mm-dd hh:nn:ss,', Now())
    + AData);
    end);
  }
end;

{ TTGPServiceDiscoveryUDPClient }

procedure TTGPServiceDiscoveryUDPClient.Activate(pActive: Boolean);

var
  lIdIPMCastClient: TIdIPMCastClient;
  lPort: Cardinal;
  lActive: Boolean;
begin
  if (pActive = False) then
  begin
    for lIdIPMCastClient in FIdIPMCastClientList do
    begin
      lIdIPMCastClient.Active := False;
    end;
  end
  else
  begin // ALE 20150908 try to activate the multicast server
    FPort := 0;
    lActive := True;
    for lPort := FPortLow to FPortHigh do
    begin
      for lIdIPMCastClient in FIdIPMCastClientList do
      begin
        // ALE 20150910 MacBook Air
        lIdIPMCastClient.Bindings[0].Port := lPort;
        lIdIPMCastClient.MulticastGroup := FMulticastGroup;
        try
          lIdIPMCastClient.Active := True;
        except
          lActive := False;
        end;
      end;
      if (lActive = True) then
      begin
        FPort := lPort;
        FActive := lActive;
        break;
      end;
    end;
  end;
end;

constructor TTGPServiceDiscoveryUDPClient.Create(AOwner: TComponent);

var
  {$IFDEF MSWINDOWS}lI: NativeInt;{$ENDIF}
  lMCClient: TIdIPMCastClient;
  lSH: TIdSocketHandle;
begin
  inherited;

  FActive := False;
  FPort := 0;
  FPortLow := 45353;
  FPortHigh := 45362;
  FGroup := 'TGP';
  FMulticastGroup := '224.239.1.20';

  FLocalIPs := TIdStackLocalAddressList.Create;

  FIdIPMCastClientList := TList<TIdIPMCastClient>.Create;

{$IFDEF MSWINDOWS}
  // ALE 20150903 tinker with listing local IPs for binding
  TIdStack.IncUsage;
  try
    GStack.GetLocalAddressList(FLocalIPs);
  finally
    TIdStack.DecUsage;
  end;
  for lI := FLocalIPs.Count - 1 downto 0 do
  begin
    if (FLocalIPs.Addresses[lI].IPVersion <> TIdIPVersion.Id_IPv4) then
    begin
      FLocalIPs.Delete(lI);
    end;
  end;

  // ALE 20150906 build a CastServer for each IP on the system
  for lI := 0 to FLocalIPs.Count - 1 do
  begin
    FIdIPMCastClientList.Add(TIdIPMCastClient.Create(nil));
    lMCClient := FIdIPMCastClientList[FIdIPMCastClientList.Count - 1];
    lMCClient.Bindings.Clear;
    lSH := lMCClient.Bindings.Add;
    lSH.IPVersion := FLocalIPs[lI].IPVersion;
    lSH.IP := FLocalIPs[lI].IPAddress;
    lSH.Port := FPort;
    lMCClient.DefaultPort := FPort;
    lMCClient.MulticastGroup := FMulticastGroup;
    lMCClient.ReuseSocket := TIdReuseSocket.rsTrue;
    lMCClient.OnIPMCastRead := IPMCastRead;
  end;
{$ELSE}
  // ALE 20150911 for non-windows, go with the 0.0.0.0 binding
  FIdIPMCastClientList.Add(TIdIPMCastClient.Create(nil));
  lMCClient := FIdIPMCastClientList[FIdIPMCastClientList.Count - 1];
  lMCClient.Bindings.Clear;
  lSH := lMCClient.Bindings.Add;
  lSH.IPVersion := TIdIPVersion.Id_IPv4;;
  lSH.IP := '0.0.0.0';
  lSH.Port := FPort;
  lMCClient.IPVersion := TIdIPVersion.Id_IPv4;
  lMCClient.DefaultPort := FPort;
  lMCClient.MulticastGroup := FMulticastGroup;
  lMCClient.ReuseSocket := TIdReuseSocket.rsTrue;
  lMCClient.OnIPMCastRead := IPMCastRead;
{$ENDIF}
end;

destructor TTGPServiceDiscoveryUDPClient.Destroy;

begin
  FLocalIPs.Destroy;
  FIdIPMCastClientList.Destroy;

  inherited;
end;

procedure TTGPServiceDiscoveryUDPClient.IPMCastRead(Sender: TObject;
  const AData: TIdBytes; ABinding: TIdSocketHandle);
begin
  // ALE 20150910 Individual Clients can call this to pump the message up to
  // the TTGPServiceDiscoveryUDPClient
  if Assigned(OnIPMCastRead) then
  begin
    OnIPMCastRead(Sender, AData, ABinding);
  end;

end;

end.