program upnp;
{$MODE OBJFPC}{$H+}
uses
Classes,
blcksock,
synautil,
SysUtils,
RegExpr,
httpsend;
function GetStringBetweenAndStrip(var str: string; startStr, endStr: string): string;
var
startPos, endPos: integer;
begin
startStr := uppercase(startStr);
endStr := uppercase(endStr);
startPos := Pos(startStr, uppercase(str));
if startPos = 0 then exit('');
startPos := startPos + Length(startStr);
endPos := Pos(endStr, uppercase(str), startPos);
if endPos = 0 then exit('');
Result := Copy(str, startPos, endPos - startPos);
// strip the string
startPos := startPos - Length(startStr);
endPos := endPos + Length(endStr);
System.Delete(str, startPos, endPos - startPos);
end;
var
GatewayIP, Location, Base, Found, Found1, Service, S: string;
ServiceType: string;
Socket: TUDPBlockSocket;
Response: TStringList;
HTTP: THTTPSend;
ResultCode: integer;
Idx: integer;
eH, eP, Pr, iP, iH, iE, iD, iL: string;
begin
GatewayIP := '192.168.0.1'; // I used hardcoded Gateway here. You can also listen for any other upnp device and pick that one.
S := 'M-SEARCH * HTTP/1.1'#13#10 + 'HOST: 239.255.255.250:1900'#13#10 + 'MAN: "ssdp:discover"'#13#10 + 'MX: 3'#13#10 + 'ST: upnp:rootdevice'#13#10#13#10;
Socket := TUDPBlockSocket.Create;
Socket.EnableBroadcast(True);
Socket.Connect(GatewayIP, '1900');
Socket.SendString(S);
repeat
if Socket.CanRead(3000) then
begin
Found := Socket.RecvPacket(3000);
if Pos('LOCATION: ', uppercase(Found)) > 0 then
begin
Location := Copy(Found, Pos('LOCATION:', uppercase(Found)) + 9);
Location := Trim(Copy(Location, 1, Pos(#13#10, Location) - 1));
writeln('Location is ' + Location);
Response := TStringList.Create;
try
HttpGetText(Location, Response);
Found := Response.Text;
Base := Location; // take base of Location for control
while (Base <> '') and (Location[Length(Base)] <> '/') do Delete(Base, Length(Base), 1);
if Base <> '' then Delete(Base, Length(Base), 1);
writeln('Base is ' + Base);
// loop all services
repeat
Service := GetStringBetweenAndStrip(Found, '<service>', '</service>');
if Pos(uppercase(':WANIPConnection:'), uppercase(service)) > 0 then
begin
S := GetStringBetweenAndStrip(Service, '<SCPDURL>', '</SCPDURL>');
if S <> '' then
begin
Location := Base + S;
writeln('SCPDURL is ' + Location);
HttpGetText(Location, Response);
S := Response.Text;
if Pos(uppercase('<name>AddPortMapping</name>'), uppercase(S)) > 0 then
begin
ServiceType := GetStringBetweenAndStrip(Service, '<serviceType>', '</serviceType>');
S := GetStringBetweenAndStrip(Service, '<controlURL>', '</controlURL>');
Location := Base + S;
writeln('Control URL is ' + Location);
// HERE WE INSERT
s := '<?xml version="1.0"?>';
s := s + '<SOAP-ENV:Envelope xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/" SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">';
s := s + '<SOAP-ENV:Body>';
s := s + ' <m:AddPortMapping xmlns:m="urn:schemas-upnp-org:service:WANIPConnection:1">';
s := s + ' <NewRemoteHost></NewRemoteHost>';
s := s + ' <NewExternalPort>3331</NewExternalPort>';
s := s + ' <NewProtocol>UDP</NewProtocol>';
s := s + ' <NewInternalPort>4444</NewInternalPort>';
s := s + ' <NewInternalClient>192.168.0.4</NewInternalClient>';
s := s + ' <NewEnabled>1</NewEnabled>';
s := s + ' <NewPortMappingDescription>test</NewPortMappingDescription>';
s := s + ' <NewLeaseDuration>0</NewLeaseDuration>';
s := s + ' </m:AddPortMapping>';
s := s + '</SOAP-ENV:Body>';
s := s + '</SOAP-ENV:Envelope>';
HTTP := THTTPSend.Create;
try
WriteStrToStream(HTTP.Document, S);
HTTP.MimeType := 'text/xml; charset="utf-8"';
http.Headers.Add('SOAPAction: "urn:schemas-upnp-org:service:WANIPConnection:1#AddPortMapping"');
if HTTP.HTTPMethod('POST', Location) then
begin
Resultcode := HTTP.ResultCode;
Response.LoadFromStream(HTTP.Document);
Found := Response.Text;
writeln(found);
end;
finally
HTTP.Free;
end;
// HERE WE CHECK
Idx := 0;
repeat
S := '';
S := S + '<?xml version="1.0" encoding="utf-8"?>';
S := S + '<s:Envelope xmlns:s="http://schemas.xmlsoap.org/soap/envelope/" s:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">';
S := S + ' <s:Body>';
S := S + ' <u:GetGenericPortMappingEntry xmlns:u="urn:schemas-upnp-org:service:WANIPConnection:1">';
S := S + ' <NewPortMappingIndex>' + IntToStr(Idx) + '</NewPortMappingIndex>';
S := S + ' </u:GetGenericPortMappingEntry>';
S := S + ' </s:Body>';
S := S + '</s:Envelope>';
HTTP := THTTPSend.Create;
try
WriteStrToStream(HTTP.Document, S);
HTTP.MimeType := 'text/xml; charset="utf-8"';
HTTP.Headers.Add('SOAPAction: ' + ServiceType + '#GetGenericPortMappingEntry');
if HTTP.HTTPMethod('POST', Location) then
begin
Resultcode := HTTP.ResultCode;
Response.LoadFromStream(HTTP.Document);
Found := Response.Text;
// writeln(found);
repeat
Found1 := GetStringBetweenAndStrip(Found, '<u:GetGenericPortMappingEntryResponse', '</u:GetGenericPortMappingEntryResponse>');
if Found1 <> '' then
begin
eH := GetStringBetweenAndStrip(Found1, '<NewRemoteHost>', '</NewRemoteHost>');
eP := GetStringBetweenAndStrip(Found1, '<NewExternalPort>', '</NewExternalPort>');
Pr := GetStringBetweenAndStrip(Found1, '<NewProtocol>', '</NewProtocol>');
iP := GetStringBetweenAndStrip(Found1, '<NewInternalPort>', '</NewInternalPort>');
iH := GetStringBetweenAndStrip(Found1, '<NewInternalClient>', '</NewInternalClient>');
iE := GetStringBetweenAndStrip(Found1, '<NewEnabled>', '<NewEnabled>');
iD := GetStringBetweenAndStrip(Found1, '<NewPortMappingDescription>', '</NewPortMappingDescription>');
iL := GetStringBetweenAndStrip(Found1, '<NewLeaseDuration>', '</NewLeaseDuration>');
S := Format('%s %s:%s -> %s:%s En: %s De: %s Le: %s', [Pr, eH, eP, iH, iP, iE, iD, iL]);
writeln(S);
end;
until Found1 = '';
end;
finally
HTTP.Free;
end;
Inc(Idx);
until Resultcode <> 200;
end;
end;
end;
until service = '';
finally
Response.Free;
end;
end;
break;
end;
sleep(100);
until False;
Socket.CloseSocket;
Socket.Free;
writeln('we are done, press enter');
readln;
end.
WIKI Timeout issues
