[espinete]

Unidad "Uupnp.pas"

Código Delphi [-]
unit UuPnP;

interface

uses
  System.SysUtils, System.Classes, idGlobal, MSXML, ComObj;

type
  TDebugEvent = procedure(const aText: String) of object;

  TuPnP = class(TComponent)
  private const
    WAN_IP_CONN_SERVICE = 'WANIPConnection:1';
    WAN_PPP_CONN_SERVICE = 'WANPPPConnection:1';
    WAN_IP_CONN_SERVICE_TYPE = 'urn:schemas-upnp-org:service:WANIPConnection:1';
  private
    FDeviceIP: String;
    FDevicePort: TIdPort;
    FDeviceControlURL: String;
    FExternalIP: String;
    FOnDebug: TDebugEvent;
    function GetDiscovered: Boolean;
  public
    FfriendlyName: String;
    Fmanufacturer: String;
    FmodelName: String;
    constructor Create(AOwner: TComponent); override;

    procedure Discover;
    function AddPortMapping(const aPort: TIdPort;desc:string): Boolean;
    procedure DeletePortMapping(const aPort: TIdPort);
    function GetExternalIP: String;

    property Discovered: Boolean read GetDiscovered;

    property OnDebug: TDebugEvent read FOnDebug write FOnDebug;
  end;

implementation

uses IdStack, IdBaseComponent, IdComponent, IdUDPBase, IdUDPClient,
  IdTCPConnection, IdTCPClient, IdHTTP, IdUri;

{ TuPnP }

function TuPnP.AddPortMapping(const aPort: TIdPort;desc:string): Boolean;
var
  LNet: TIdTCPClient;
  LResponseStr: String;
  LSendData: TStringStream;
  LHeaderStr: String;
begin
  Result := False;

  try
    LNet := TIdTCPClient.Create(Self);
    LSendData := TStringStream.Create('');

    LSendData.WriteString('');
    LSendData.WriteString('');
    LSendData.WriteString('');
    LSendData.WriteString(Format('', [WAN_IP_CONN_SERVICE_TYPE]));

    LSendData.WriteString('');
    LSendData.WriteString(Format('%d', [aPort]));
    LSendData.WriteString(Format('%s', ['TCP']));
    LSendData.WriteString(Format('%d', [aPort]));
    LSendData.WriteString(Format('%s', [GStack.LocalAddress]));
    LSendData.WriteString(Format('%d', [1]));
    LSendData.WriteString(Format('%s', [desc]));
    LSendData.WriteString(Format('%d', [0]));

    LSendData.WriteString('');
    LSendData.WriteString('');
    LSendData.WriteString('');

    LHeaderStr := 'POST %s HTTP/1.1' + EOL
      + 'HOST: %s:%d' + EOL
      + 'SOAPACTION: "%s"' + EOL
      + 'CONTENT-TYPE: text/xml ; charset="utf-8"'+ EOL
      + 'CONTENT-LENGTH: %d'+ EOL
      + EOL;
    LHeaderStr := Format(LHeaderStr, [FDeviceControlURL, FDeviceIP, FDevicePort,
      WAN_IP_CONN_SERVICE_TYPE + '#' + 'AddPortMapping', LSendData.Size]);

    // �������
    if Assigned(FOnDebug) then
    begin
      FOnDebug('[AddPortMapping] ' + LHeaderStr + LSendData.DataString);
    end;

    try
      LNet.Host := FDeviceIP;
      LNet.Port := FDevicePort;
      LNet.Connect;
      if LNet.Connected then
      begin
        // �������� ������
        LNet.IOHandler.WriteLn(LHeaderStr + LSendData.DataString, IndyTextEncoding_UTF8);

        // �������� �����
        LResponseStr := LNet.IOHandler.ReadLn(LF, 1000 * 10);

        // ��������� �����
        if (Pos('200 OK', LResponseStr) <> 0) then
        begin
            Result := True;
        end;

//        if LNet.IOHandler.CheckForDataOnSource(1000) then
//        begin
//          LResponseStr := LNet.IOHandler.ReadString(LNet.IOHandler.InputBuffer.Size);
//          // ��������� ������� ���� �������� �����
//          if LNet.IOHandler.CheckForDataOnSource(1000) then
//          begin
//            LResponseStr := LNet.IOHandler.ReadString(LNet.IOHandler.InputBuffer.Size);
//          end;
//        end;
      end;

      // �������
      if Assigned(FOnDebug) then
      begin
        FOnDebug('[AddPortMapping] ' + LResponseStr);
      end;

      // ��������� �����
//      if (LResponseStr <> '') then
//      begin
//        LXml := CreateXMLDoc;
//        LXml.LoadFromXML(LResponseStr);
//        LNNode := LXml.DocumentElement.SelectNode('//u:AddPortMappingResponse');
//        if Assigned(LNNode) then
//        begin
//          Result := True;
//        end;
//      end;
    except
      on E: Exception do
      begin
        // �������
        if Assigned(FOnDebug) then
        begin
          FOnDebug('[AddPortMapping] ' + E.Message);
        end;
      end;
    end;
  finally
    FreeAndNil(LNet);
    FreeAndNil(LSendData);
  end;
end;

constructor TuPnP.Create(AOwner: TComponent);
begin
  inherited;
  FDeviceIP := '';
  FDevicePort := 0;
  FExternalIP := '';
end;

procedure TuPnP.DeletePortMapping(const aPort: TIdPort);
var
  LNet: TIdTCPClient;
  LResponseStr: String;
  LHeaderStr: String;
  LSendData: TStringStream;
begin
  try
    LNet := TIdTCPClient.Create(Self);
    LSendData := TStringStream.Create('');

    LSendData.WriteString('');
    LSendData.WriteString('');
    LSendData.WriteString('');
    LSendData.WriteString(Format('eletePortMapping xmlns:u="%s">', [WAN_IP_CONN_SERVICE_TYPE]));

    LSendData.WriteString('');
    LSendData.WriteString(Format('%d', [aPort]));
    LSendData.WriteString(Format('%s', ['TCP']));

    LSendData.WriteString('eletePortMapping>');
    LSendData.WriteString('');
    LSendData.WriteString('');

    LHeaderStr := 'POST %s HTTP/1.1' + EOL
      + 'HOST: %s:%d' + EOL
      + 'SOAPACTION: "%s"' + EOL
      + 'CONTENT-TYPE: text/xml ; charset="utf-8"'+ EOL
      + 'CONTENT-LENGTH: %d'+ EOL
      + EOL;
    LHeaderStr := Format(LHeaderStr, [FDeviceControlURL, FDeviceIP, FDevicePort,
      WAN_IP_CONN_SERVICE_TYPE + '#' + 'DeletePortMapping', LSendData.Size]);

    // �������
    if Assigned(FOnDebug) then
    begin
      FOnDebug('[DeletePortMapping] ' + LHeaderStr + LSendData.DataString);
    end;

    try
      LNet.Host := FDeviceIP;
      LNet.Port := FDevicePort;
      LNet.Connect;
      if LNet.Connected then
      begin
        // �������� ������
        LNet.IOHandler.WriteLn(LHeaderStr + LSendData.DataString, IndyTextEncoding_UTF8);

        // �������� �����
        LResponseStr := LNet.IOHandler.ReadLn(LF, 1000 * 10);

        // ��������� �����
        if (Pos('200 OK', LResponseStr) <> 0) then
        begin
          //Result := True;
        end;

        // �������� �����
//        if LNet.IOHandler.CheckForDataOnSource(1000) then
//        begin
//          LResponseStr := LNet.IOHandler.ReadString(LNet.IOHandler.InputBuffer.Size);
//          // ��������� ������� ���� �������� �����
//          if LNet.IOHandler.CheckForDataOnSource(1000) then
//          begin
//            LResponseStr := LNet.IOHandler.ReadString(LNet.IOHandler.InputBuffer.Size);
//          end;
//        end;
      end;

      // �������
      if Assigned(FOnDebug) then
      begin
        FOnDebug('[DeletePortMapping] ' + LResponseStr);
      end;
    except
      on E: Exception do
      begin
        // �������
        if Assigned(FOnDebug) then
        begin
          FOnDebug('[DeletePortMapping] ' + E.Message);
        end;
      end;
    end;
  finally
    FreeAndNil(LNet);
    FreeAndNil(LSendData);
  end;
end;

procedure TuPnP.Discover;
var
  LNet: TIdUDPClient;
  LSendStr: String;
  LResponseStr: String;
  LPeerIP: String;
  LPeerPort: Word;
  LHttp: TIdHTTP;
  LStartIdx, LCount: Integer;
  LUri: TIdURI;
  LXml: IXMLDOMDocument;
  LNControlURL: IXMLDomNode;
  LNService: IXMLDomNode;
  LNServiceType: IXMLDomNode;
  LNodeList: IXMLDomNodeList;
  i: Integer;
begin
  LSendStr := 'M-SEARCH * HTTP/1.1' + EOL
    + 'MX: 2' + EOL
    + 'HOST: 239.255.255.250:1900' + EOL
    + 'MAN: "ssdp:discover"' + EOL
    + 'ST: urn:schemas-upnp-org:service:%s'+ EOL
    + EOL;

  try
    LNet := TIdUDPClient.Create(Self);
    LHttp := TIdHTTP.Create(Self);
    LUri := TIdURI.Create('');

    // ������ ����������������� ��������
    LNet.BoundIP := GStack.LocalAddress;
    LNet.Send('239.255.255.250', 1900, Format(LSendStr, [WAN_IP_CONN_SERVICE]));
    //LNet.Send('239.255.255.250', 1900, Format(LSendStr, [WAN_PPP_CONN_SERVICE]));

    // ��������� �����, ���� ������ ���� <> 0
    LPeerPort := 0;
    LNet.ReceiveTimeout := 1000;
    repeat
      LResponseStr := LNet.ReceiveString(LPeerIP, LPeerPort);
      if LPeerPort <> 0 then
      begin
        // �������
        if Assigned(FOnDebug) then
        begin
          FOnDebug('[Discover] ' + LResponseStr);
          FOnDebug('[Discover] ' + 'PeerPort: ' + IntToStr(LPeerPort));
        end;

        // ��������� ������ ��� ��������
        LStartIdx := Pos('LOCATION:', LResponseStr);
        if (LStartIdx <> 0) then
        begin
          LStartIdx := LStartIdx + Length('LOCATION:') + 1;
          LCount := Pos(EOL, LResponseStr, LStartIdx) - LStartIdx;
          LUri.URI := Copy(LResponseStr, LStartIdx, LCount);

          // �������
          if Assigned(FOnDebug) then
          begin
            FOnDebug('[Discover] ' + 'URI: ' + LUri.URI);
          end;

          // ���������� ������ � �����
          FDeviceIP := LUri.Host;
          FDevicePort := StrToInt(LUri.Port);

          // �������
          if Assigned(FOnDebug) then
          begin
            FOnDebug('[Discover] ' + 'DeviceIP: ' + FDeviceIP);
            FOnDebug('[Discover] ' + 'DevicePort: ' + IntToStr(FDevicePort));
          end;

          // ������ ����� ��������
          LResponseStr := LHttp.Get(LUri.URI);
          if (LResponseStr <> '') then
          begin
            // �������
            if Assigned(FOnDebug) then
            begin
              FOnDebug('[Discover] ' + LResponseStr);
            end;

            LXml := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
            LXml.LoadXML(LResponseStr);

            //Obtenemos información del dispositivo
            try
                LNodeList := LXml.SelectNodes('//device');
                LNService := LNodeList[0];
                LNServiceType := LNService.SelectSingleNode('friendlyName');
                if Assigned(LNServiceType) then
                    Ffriendlyname := LNServiceType.childNodes[0].nodeValue;
                LNServiceType := LNService.SelectSingleNode('manufacturer');
                if Assigned(LNServiceType) then
                    Fmanufacturer := LNServiceType.childNodes[0].nodeValue;
                LNServiceType := LNService.SelectSingleNode('modelName');
                if Assigned(LNServiceType) then
                    FmodelName := LNServiceType.childNodes[0].nodeValue;
            except
            end;

            //Recorre los "servicios" encontrados y localiza el WAN_IP_CONN_SERVICE
            LNodeList := LXml.SelectNodes('//serviceList/service');
            for i := 0 to LNodeList.length - 1 do
            begin
                LNService := LNodeList[i];
                LNServiceType := LNService.SelectSingleNode('serviceType');
                if Assigned(LNServiceType) and (LNServiceType.ChildNodes[0].NodeValue = WAN_IP_CONN_SERVICE_TYPE) then
                begin
                    LNControlURL := LNService.SelectSingleNode('controlURL');
                    if Assigned(LNControlURL) then
                    begin
                      FDeviceControlURL := LNControlURL.ChildNodes[0].NodeValue;

                      // �������
                      if Assigned(FOnDebug) then
                      begin
                        FOnDebug('[Discover] ' + 'DeviceControlURL: ' + FDeviceControlURL);
                      end;
                      Break;
                    end;
                end;
            end;
          end;
        end;
      end;
    until LPeerPort = 0;
  finally
    FreeAndNil(LNet);
    FreeAndNil(LHttp);
    FreeAndNil(LUri);
  end;
end;

function TuPnP.GetDiscovered: Boolean;
begin
  Result := (FDeviceIP <> '');
end;

function TuPnP.GetExternalIP: String;
var
  LNet: TIdTCPClient;
  LHeaderStr: String;
  LResponseStr: String;
  //LUri: TIdURI;
  LSendData: TStringStream;
  LXml: IXMLDOMDocument;
  LNNode: IXMLDomNode;
begin
  Result := FExternalIP;

  if (Result = '') then
  begin
    try
      LNet := TIdTCPClient.Create(Self);
      //LUri := TIdURI.Create('');
      LSendData := TStringStream.Create('');

//      LUri.Protocol := 'http';
//      LUri.Host := FDeviceIP;
//      LUri.Port := IntToStr(FDevicePort);
//      LUri.Document := FDeviceControlURL;

      LSendData.WriteString('');
      LSendData.WriteString('');
      LSendData.WriteString('');
      LSendData.WriteString(Format('', [WAN_IP_CONN_SERVICE_TYPE]));
      LSendData.WriteString('');
      LSendData.WriteString('');
      LSendData.WriteString('');

      LHeaderStr := 'POST %s HTTP/1.1' + EOL
        + 'HOST: %s:%d' + EOL
        + 'SOAPACTION: "%s"' + EOL
        + 'CONTENT-TYPE: text/xml ; charset="utf-8"'+ EOL
        + 'CONTENT-LENGTH: %d'+ EOL
        + EOL;
      LHeaderStr := Format(LHeaderStr, [FDeviceControlURL, FDeviceIP, FDevicePort,
        WAN_IP_CONN_SERVICE_TYPE + '#' + 'GetExternalIPAddress', LSendData.Size]);

      // �������
      if Assigned(FOnDebug) then
      begin
        FOnDebug('[GetExternalIP] ' + LHeaderStr + LSendData.DataString);
      end;

      try
        // �������
//        if Assigned(FOnDebug) then
//        begin
//          FOnDebug('[GetExternalIP] ' + 'URI: ' + LUri.URI);
//        end;

        LNet.Host := FDeviceIP;
        LNet.Port := FDevicePort;
        LNet.Connect;
        if LNet.Connected then
        begin
          // �������� ������
          LNet.IOHandler.WriteLn(LHeaderStr + LSendData.DataString, IndyTextEncoding_UTF8);

          // �������� �����
          if LNet.IOHandler.CheckForDataOnSource(1000 * 10) then
          begin
            LResponseStr := LNet.IOHandler.ReadString(LNet.IOHandler.InputBuffer.Size);
            // ��������� ������� ���� �������� �����
            if LNet.IOHandler.CheckForDataOnSource(1000 * 10) then
            begin
              LResponseStr := LResponseStr + LNet.IOHandler.ReadString(LNet.IOHandler.InputBuffer.Size);
            end;
          end;
        end;

        // �������
        if Assigned(FOnDebug) then
        begin
          FOnDebug('[GetExternalIP] ' + LResponseStr);
        end;

        if (LResponseStr <> '') then
        begin
          // �������� HTTP ���������
          LResponseStr := Copy(LResponseStr, Pos(EOL+EOL, LResponseStr) + Length(EOL+EOL), Length(LResponseStr));

          LXml := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
          LXml.LoadXML(LResponseStr);

          LNNode := LXml.SelectSingleNode('//NewExternalIPAddress');
          if Assigned(LNNode) then
          begin
            Result := LNNode.ChildNodes[0].NodeValue;
            FExternalIP := Result;
          end;
        end;
      except
        on E: Exception do
        begin
          // �������
          if Assigned(FOnDebug) then
          begin
            FOnDebug('[GetExternalIP] ' + E.Message);
          end;
        end;
      end;
    finally
      FreeAndNil(LNet);
      //FreeAndNil(LUri);
      FreeAndNil(LSendData);
    end;
  end;
end;

end.

Ejemplo de llamadas:

Código Delphi [-]

var FuPnP:TuPnP;
begin
    FuPnP:=TuPnP.Create(nil);

    //Descubrir dispositivos uPnP en la red
    FuPnP.Discover;

    //Obtenermos el nombre y fabricante del router
    edit1.Text := FuPnP.FfriendlyName;
    edit2.Text := FuPnP.Fmanufacturer;
    edit3.Text := FuPnP.FmodelName;

    //Abrir/Redirigir un Puerto
    if FuPnP.AddPortMapping(12345,'Prueba')=false then
        showmessage('no se pudo abrir el puerto')
    else
        showmessage('puerto abierto!');
end;