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;
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;
end;
if Assigned(FOnDebug) then
begin
FOnDebug('[AddPortMapping] ' + LResponseStr);
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
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]));
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);
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;
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;
LSendData: TStringStream;
LXml: IXMLDOMDocument;
LNNode: IXMLDomNode;
begin
Result := FExternalIP;
if (Result = '') then
begin
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('');
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
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
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(LSendData);
end;
end;
end;
end.
Ejemplo de llamadas:
Código Delphi
[-]
var FuPnP:TuPnP;
begin
FuPnP:=TuPnP.Create(nil);
FuPnP.Discover;
edit1.Text := FuPnP.FfriendlyName;
edit2.Text := FuPnP.Fmanufacturer;
edit3.Text := FuPnP.FmodelName;
if FuPnP.AddPortMapping(12345,'Prueba')=false then
showmessage('no se pudo abrir el puerto')
else
showmessage('puerto abierto!');
end;