盒子论坛 v2.1

{
揄栩疱嚯桤箦?疣犷蝮 uPnP
}
unit UuPnP;

interface

uses
  System.SysUtils, System.Classes, idGlobal;

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
    constructor Create(AOwner: TComponent); override;

    procedure Discover;
    function AddPortMapping(const aPort: TIdPort): 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, OXmlPDOM;

{ TuPnP }

function TuPnP.AddPortMapping(const aPort: TIdPort): Boolean;
var
  LNet: TIdTCPClient;
  LResponseStr: String;
  LSendData: TStringStream;
  LHeaderStr: String;
  LXml: OXmlPDOM.IXMLDocument;
  LNNode: PXMLNode;
begin
  Result := False;

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

    LSendData.WriteString('<?xml version="1.0" encoding="utf-8"?>');
    LSendData.WriteString('<s:Envelope xmlns:s="

http://schemas.xmlsoap.org/soap/envelope/"; s:encodingStyle="

http://schemas.xmlsoap.org/soap/encoding/";>');
    LSendData.WriteString('<s:Body>');
    LSendData.WriteString(Format('<u:AddPortMapping xmlns:u="%s">', [WAN_IP_CONN_SERVICE_TYPE]));

    LSendData.WriteString('<NewRemoteHost></NewRemoteHost>');
    LSendData.WriteString(Format('<NewExternalPort>%d</NewExternalPort>', [aPort]));
    LSendData.WriteString(Format('<NewProtocol>%s</NewProtocol>', ['TCP']));
    LSendData.WriteString(Format('<NewInternalPort>%d</NewInternalPort>', [aPort]));
    LSendData.WriteString(Format('<NewInternalClient>%s</NewInternalClient>', [GStack.LocalAddress]));
    LSendData.WriteString(Format('<NewEnabled>%d</NewEnabled>', [1]));
    LSendData.WriteString(Format('<NewPortMappingDescription>%s</NewPortMappingDescription>', ['DORF_CHAT_PORT_MAPPING']));
    LSendData.WriteString(Format('<NewLeaseDuration>%d</NewLeaseDuration>', [0]));

    LSendData.WriteString('</u:AddPortMapping>');
    LSendData.WriteString('</s:Body>');
    LSendData.WriteString('</s:Envelope>');

    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('<?xml version="1.0" encoding="utf-8"?>');
    LSendData.WriteString('<s:Envelope xmlns:s="

http://schemas.xmlsoap.org/soap/envelope/"; s:encodingStyle="

http://schemas.xmlsoap.org/soap/encoding/";>');
    LSendData.WriteString('<s:Body>');
    LSendData.WriteString(Format('<u:DeletePortMapping xmlns:u="%s">', [WAN_IP_CONN_SERVICE_TYPE]));

    LSendData.WriteString('<NewRemoteHost></NewRemoteHost>');
    LSendData.WriteString(Format('<NewExternalPort>%d</NewExternalPort>', [aPort]));
    LSendData.WriteString(Format('<NewProtocol>%s</NewProtocol>', ['TCP']));

    LSendData.WriteString('</u:DeletePortMapping>');
    LSendData.WriteString('</s:Body>');
    LSendData.WriteString('</s:Envelope>');

    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: OXmlPDOM.IXMLDocument;
  LNControlURL: PXMLNode;
  LNService: PXMLNode;
  LNServiceType: PXMLNode;
  LNodeList: IXMLNodeList;
  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 := CreateXMLDoc;
          LXml.LoadFromXML(LResponseStr);
          LNodeList := LXml.DocumentElement.SelectNodes('//serviceList/service');

          for i := 0 to LNodeList.Count - 1 do
          begin
          LNService := LNodeList[i];
          LNServiceType := LNService.SelectNode('serviceType');
          if Assigned(LNServiceType) and (LNServiceType.ChildNodes[0].NodeValue = WAN_IP_CONN_SERVICE_TYPE) then
          begin
          LNControlURL := LNService.SelectNode('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: OXmlPDOM.IXMLDocument;
  LNNode: PXMLNode;
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('<?xml version="1.0" encoding="utf-8"?>');
      LSendData.WriteString('<s:Envelope xmlns:s="

http://schemas.xmlsoap.org/soap/envelope/"; s:encodingStyle="

http://schemas.xmlsoap.org/soap/encoding/";>');
      LSendData.WriteString('<s:Body>');
      LSendData.WriteString(Format('<u:GetExternalIPAddress xmlns:u="%s">', [WAN_IP_CONN_SERVICE_TYPE]));
      LSendData.WriteString('</u:GetExternalIPAddress>');
      LSendData.WriteString('</s:Body>');
      LSendData.WriteString('</s:Envelope>');

      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 := CreateXMLDoc;
          LXml.LoadFromXML(LResponseStr);
          LNNode := LXml.DocumentElement.SelectNode('//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.
----------------------------------------------

作者：

xuchuantao (暗黑天使)	★☆☆☆☆	-
	普通会员

2016/9/22 22:29:10

1楼：

需要svn://svn.code.sf.net/p/oxml/code
----------------------------------------------

作者：

xuchuantao (暗黑天使)	★☆☆☆☆	-
	普通会员

2016/9/22 22:30:02

2楼：

uPnP := TuPnP.Create(self);
  uPnP.Discover;
  if uPnP.Discovered then
  begin
    showmessage(uPnP.GetExternalIP);
  end;
  if uPnP.AddPortMapping(1234) then
  begin
    showmessage('映射完成');
  end;
  uPnP.DeletePortMapping(1234);
  uPnP.Free;
----------------------------------------------

作者：

nevergrief (孤独骑士)	★☆☆☆☆	-
	盒子活跃会员

2016/9/22 23:05:27

3楼：

映射什么东西，功能是什么，能不能讲讲？
----------------------------------------------
只有偏执狂才能生存！

作者：

hujiacheng ( 旺财)	★☆☆☆☆	-
	普通会员

2016/9/22 23:08:53

4楼：

udp? tcp?
----------------------------------------------
免费的FTP

https://download-installer.cdn.mozilla.net/pub/firefox/releases/43.0/win64/zh-CN/https://cc.embarcadero.com/Author/575019>http://delphi-z.ru

https://download-installer.cdn.mozilla.net/pub/firefox/releases/43.0/win64/zh-CN/https://cc.embarcadero.com/Author/575019>http://delphi.icm.edu.pl/ftp/

https://download-installer.cdn.mozilla.net/pub/firefox/releases/43.0/win64/zh-CN/https://cc.embarcadero.com/Author/575019>http://delphi-z.ru

https://download-installer.cdn.mozilla.net/pub/firefox/releases/43.0/win64/zh-CN/https://cc.embarcadero.com/Author/575019

作者：

xuchuantao (暗黑天使)	★☆☆☆☆	-
	普通会员

2016/9/22 23:19:12

5楼：

自动端口映射
----------------------------------------------

作者：

xuchuantao (暗黑天使)	★☆☆☆☆	-
	普通会员

2016/9/22 23:19:48

6楼：

用于在路由器上自动端口映射
----------------------------------------------

作者：

xuchuantao (暗黑天使)	★☆☆☆☆	-
	普通会员

2016/9/22 23:24:44

7楼：

http://itbbs.pconline.com.cn/network/12473184.html
----------------------------------------------

作者：

xuchuantao (暗黑天使)	★☆☆☆☆	-
	普通会员

2016/9/22 23:25:05

8楼：

上面幽介绍
----------------------------------------------

作者：

cuit_xiong (熊猫)	★☆☆☆☆	-
	普通会员

2016/9/23 9:26:30

9楼：

楼主你发的svn地址和你发帖这个UPnP不是一个东西啊，是不是发错了，检查下
----------------------------------------------
-

作者：

cuit_xiong (熊猫)	★☆☆☆☆	-
	普通会员

2016/9/23 9:44:55

10楼：

按照你写的demo运行报错
uPnP := TuPnP.Create(self);
  uPnP.Discover;
  if uPnP.Discovered then
  begin
    showmessage(uPnP.GetExternalIP);
  end;
  if uPnP.AddPortMapping(1234) then
  begin
    showmessage('映射完成');
  end;
  uPnP.DeletePortMapping(1234);//这句产生异常
  uPnP.Free;
----------------------------------------------
-

作者：

cuit_xiong (熊猫)	★☆☆☆☆	-
	普通会员

2016/9/23 10:13:36

11楼：

请问楼主是不是要在路由器里开启UPnP功能才行
----------------------------------------------
-

作者：

wang_80919 (Flying Wang)	★☆☆☆☆	-
	普通会员

2016/9/23 10:19:03

11楼：

7 楼的文章真有意思。
1 路由器质量或芯片性能问题
2 uPNP 协议安全问题。
3 蹭网。

他真正的问题就是蹭网。

如果没人蹭他的网，就没那么多问题了。
----------------------------------------------
(C)(P)Flying Wang

作者：

xuchuantao (暗黑天使)	★☆☆☆☆	-
	普通会员

2016/9/23 12:44:39

12楼：

要在路由器里开启UPnP功能才行,SVN上的是需要用到的XML解析单元
----------------------------------------------

作者：

cuit_xiong (熊猫)	★☆☆☆☆	-
	普通会员

2016/9/23 13:03:57

13楼：

谢谢楼主，我贴个完整的出来
Delphi-uPnP git地址：https://github.com/igor-shikarev/Delphi-uPnP
oxml svn地址：svn://svn.code.sf.net/p/oxml/code

UPnP需要用到oxml
----------------------------------------------
-

信息

登陆以后才能回复