Imports <xmlns:ud="urn:schemas-upnp-org:device-1-0">
Imports <xmlns:uc="urn:schemas-upnp-org:service:ConnectionManager:1">
Imports <xmlns:ut="urn:schemas-upnp-org:service:AVTransport:1">
Imports <xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
Module Module1
Sub Main()
Dim p As New ConsoleProgress
' Here are three different techniques for doing SSDP discovery...
Dim deviceLocations1 = TestSsdpFromConsoleAsync(p).GetAwaiter().GetResult() ' uses .NET45 for raw SSDP; not available in app store
Dim deviceLocations2 = TestSsdpFromWin8Async(p).GetAwaiter().GetResult() ' uses WinRT for raw SSDP; allowed in app store
Dim deviceLocations3 = TestMediaRendererEnumerationFromWin8Async().GetAwaiter().GetResult() ' uses WinRT DeviceEnumeration; allowed in app store
Dim deviceLocations = deviceLocations1.Concat(deviceLocations2).Concat(deviceLocations3).Distinct
'
For Each device In deviceLocations
Console.WriteLine(device)
' We have two different techniques for playing music to an AVTransport device...
If device.AVTransportControlUrl Is Nothing Then Continue For
TestUpnpFromConsoleAsync(device, p).GetAwaiter().GetResult()
TestUpnpFromWin8Async(device, p).GetAwaiter().GetResult()
Next
End Sub
Class ConsoleProgress
Implements IProgress(Of String)
Public Sub Report(value As String) Implements IProgress(Of String).Report
Console.WriteLine(value)
End Sub
End Class
Class MediaRendererDevice
Public FriendlyName As String
Public AVTransportControlUrl As Uri
Public ConnectionManagerControlUrl As Uri
Public LocalUri As Uri
Public Overrides Function ToString() As String
Return String.Format("{1} - {2}{0} ConnectionManager:{3}{0} AVTransport:{4}", vbCrLf, FriendlyName, LocalUri, ConnectionManagerControlUrl, AVTransportControlUrl)
End Function
Public Overrides Function GetHashCode() As Integer
Return 1
End Function
Public Overrides Function Equals(obj As Object) As Boolean
Dim Him = TryCast(obj, MediaRendererDevice) : If Him Is Nothing Then Return False
Return Me.FriendlyName.Equals(Him.FriendlyName) AndAlso
Me.AVTransportControlUrl.PathAndQuery.Equals(Him.AVTransportControlUrl.PathAndQuery) AndAlso
Me.ConnectionManagerControlUrl.PathAndQuery.Equals(Him.ConnectionManagerControlUrl.PathAndQuery)
' We don't compare on hostnames. That's because a device that we know through IPv6 and IPv4 will have
' different hostnames but will still the the same device.
' Instead of FriendlyName, we might have compared against SSDP <UDN>uuid:5f9ec1b3-ed59-1900-4530-0007f521ebd6</UDN>
' which is probably the same as WinRT's PnpObjectType.Device::System.Devices.ContainerId=5f9ec1b3-ed59-1900-4530-0007f521ebd6
' and hope that this is how WinRT populated that field. But I reckon that FriendlyName is a better bet.
End Function
End Class
Async Function TestMediaRendererEnumerationFromWin8Async() As Task(Of MediaRendererDevice())
Dim results As New List(Of MediaRendererDevice)
'
' Notionally we should search for all devices that are urn:schemas-upnp-org:device:MediaRenderer:1
' But the device-enumeration API doesn't support a search by device-type.
' Instead, rely on the fact that all MediaRenderers have ConnectionManager, RenderingControl and (optionally) AVTransport
' Obtained by looking in Windows SDK headers for PKEYs, and figuring out by experiment that this refers to the control Url:
Dim PKEY_PNPX_ServiceControlUrl = "{656A3BB3-ECC0-43FD-8477-4AE0404A96CD},16388"
' Obtained by experimenting with three different MediaRenderers, and verifying that they all used these interfaces (service-types):
' DeviceInterface::System.Devices.InterfaceClassGuid is a reliable way of finding servicetypes.
' DeviceInterface::System.Devices.ServiceId is unreliable.
Dim RenderingControlInterfaceClass = New Guid("8660e926-ff3d-580c-959e-8b8af44d7cde")
Dim ConnectionManagerInterfaceClass = New Guid("ae9eb9c4-8819-51d8-879d-9a42ffb89d4e")
Dim AVTransportInterfaceClass = New Guid("4c38e836-6a2f-5949-9406-1788ea20d1d5")
Dim RenderingControls = Await Windows.Devices.Enumeration.Pnp.PnpObject.FindAllAsync(
Windows.Devices.Enumeration.Pnp.PnpObjectType.DeviceInterface,
{"System.Devices.DeviceInstanceId", "System.Devices.InterfaceClassGuid", "System.Devices.ContainerId"},
"System.Devices.InterfaceClassGuid:=""{" & RenderingControlInterfaceClass.ToString() & "}""")
For Each device In RenderingControls
If Not device.Properties.ContainsKey("System.Devices.DeviceInstanceId") Then Continue For
If Not device.Properties.ContainsKey("System.Devices.ContainerId") Then Continue For
Dim id = CStr(device.Properties("System.Devices.DeviceInstanceId"))
Dim containerId = CType(device.Properties("System.Devices.ContainerId"), Guid)
Dim ConnectionManagerInterface = (Await Windows.Devices.Enumeration.Pnp.PnpObject.FindAllAsync(
Windows.Devices.Enumeration.Pnp.PnpObjectType.DeviceInterface,
{"System.Devices.DeviceInstanceId", "System.Devices.InterfaceClassGuid", PKEY_PNPX_ServiceControlUrl},
"System.Devices.DeviceInstanceId:=""" & id & """ AND System.Devices.InterfaceClassGuid:=""{" & ConnectionManagerInterfaceClass.ToString() & "}""")).FirstOrDefault
If ConnectionManagerInterface Is Nothing Then Continue For
If Not ConnectionManagerInterface.Properties.ContainsKey(PKEY_PNPX_ServiceControlUrl) Then Continue For
Dim connectionManagerUrl = New Uri(CStr(ConnectionManagerInterface.Properties(PKEY_PNPX_ServiceControlUrl)))
'
Dim AVTransportInterface = (Await Windows.Devices.Enumeration.Pnp.PnpObject.FindAllAsync(
Windows.Devices.Enumeration.Pnp.PnpObjectType.DeviceInterface,
{"System.Devices.DeviceInstanceId", "System.Devices.InterfaceClassGuid", PKEY_PNPX_ServiceControlUrl},
"System.Devices.DeviceInstanceId:=""" & id & """ AND System.Devices.InterfaceClassGuid:=""{" & AVTransportInterfaceClass.ToString() & "}""")).FirstOrDefault
If Not AVTransportInterface Is Nothing AndAlso Not AVTransportInterface.Properties.ContainsKey(PKEY_PNPX_ServiceControlUrl) Then AVTransportInterface = Nothing
Dim avTransportUrl = If(AVTransportInterface Is Nothing, Nothing, New Uri(CStr(AVTransportInterface.Properties(PKEY_PNPX_ServiceControlUrl))))
'
Dim Container = Await Windows.Devices.Enumeration.Pnp.PnpObject.CreateFromIdAsync(
Windows.Devices.Enumeration.Pnp.PnpObjectType.DeviceContainer,
containerId.ToString(),
{"System.Devices.Connected", "System.Devices.FriendlyName"})
If Container Is Nothing Then Continue For
If Not Container.Properties.ContainsKey("System.Devices.Connected") Then Continue For
If Not Container.Properties.ContainsKey("System.Devices.FriendlyName") Then Continue For
Dim connected = CBool(Container.Properties("System.Devices.Connected"))
Dim friendlyName = CStr(Container.Properties("System.Devices.FriendlyName"))
If Not connected Then Continue For
'
' We need to establish a URL that identifies us ourselves, so we can set up a server
' and have the device make HTTP-GET requests to us. Basically, a local IP. But if we
' have multiple network interfaces (and multiple IPs), then which is the best one for
' the device to make requests to? Use a dummy connection to the device, to find out...
Try
Dim localUri As Uri
Using c As New Net.Sockets.TcpClient(connectionManagerUrl.DnsSafeHost, connectionManagerUrl.Port)
Dim addr = CType(c.Client.LocalEndPoint, Net.IPEndPoint).Address
Dim localHost = addr.ToString()
If addr.AddressFamily = Net.Sockets.AddressFamily.InterNetworkV6 Then localHost = "[" & localHost & "]"
localUri = New Uri("http://" & localHost)
End Using
results.Add(New MediaRendererDevice With {.FriendlyName = friendlyName, .ConnectionManagerControlUrl = connectionManagerUrl, .AVTransportControlUrl = avTransportUrl, .LocalUri = localUri})
Catch ex As Net.Sockets.SocketException
' oh well, I suppose we can't connect - sometimes the "connected" flag is incorrect
End Try
Next
Return results.ToArray()
End Function
Async Function TestSsdpFromConsoleAsync(progress As IProgress(Of String)) As Task(Of MediaRendererDevice())
Dim remoteEp = New Net.IPEndPoint(Net.IPAddress.Parse("239.255.255.250"), 1900) ' standard multicast address+port for SSDP
Dim locations As New HashSet(Of Tuple(Of Uri, Uri))
' We need to send out the multicast packet on all available network interfaces.
' This code detects the local IP addresses corresponding to each interface
Dim localIps = From network In Net.NetworkInformation.NetworkInterface.GetAllNetworkInterfaces()
Where network.OperationalStatus = Net.NetworkInformation.OperationalStatus.Up
Where network.NetworkInterfaceType <> Net.NetworkInformation.NetworkInterfaceType.Loopback
Let localAddr = (From uaddr In network.GetIPProperties.UnicastAddresses Where uaddr.Address.AddressFamily = Net.Sockets.AddressFamily.InterNetwork).FirstOrDefault
Where Not localAddr Is Nothing
Select localAddr.Address
For Each localIp In localIps
Using socket As New Net.Sockets.Socket(Net.Sockets.AddressFamily.InterNetwork, Net.Sockets.SocketType.Dgram, Net.Sockets.ProtocolType.Udp)
socket.SetSocketOption(Net.Sockets.SocketOptionLevel.Socket, Net.Sockets.SocketOptionName.ReuseAddress, True)
socket.SetSocketOption(Net.Sockets.SocketOptionLevel.IP, Net.Sockets.SocketOptionName.AddMembership, New Net.Sockets.MulticastOption(remoteEp.Address))
socket.SetSocketOption(Net.Sockets.SocketOptionLevel.IP, Net.Sockets.SocketOptionName.MulticastTimeToLive, 1)
socket.Bind(New Net.IPEndPoint(localIp, 0))
Dim receiverTask = Task.Run(
Sub()
Dim responsebuf = New Byte(51200) {}
Do
Try
Dim ep As Net.EndPoint = New Net.IPEndPoint(Net.IPAddress.Any, 0)
Dim len = socket.ReceiveFrom(responsebuf, ep)
If Not progress Is Nothing Then progress.Report("Received from " & ep.ToString() & vbCrLf & Text.Encoding.UTF8.GetString(responsebuf, 0, len))
Dim location = ParseSsdpResponse(responsebuf, len)
If Not location Is Nothing Then locations.Add(Tuple.Create(location, New Uri("http://" & localIp.ToString)))
Catch ex As Net.Sockets.SocketException When ex.ErrorCode = 10004
Return ' WSACancelBlockingCall, when the socket is closed
End Try
Loop
End Sub)
Dim request = CreateSsdpRequest(remoteEp.ToString())
If Not progress Is Nothing Then progress.Report("-------> [multicast]" & vbCrLf & Text.Encoding.UTF8.GetString(request))
socket.SendTo(request, remoteEp)
Await Task.Delay(20)
socket.SendTo(request, remoteEp)
Await Task.Delay(20)
socket.SendTo(request, remoteEp)
Await Task.Delay(1000)
socket.Close()
Await receiverTask
End Using
Next
Dim devices As New List(Of MediaRendererDevice)
For Each location In locations
Dim device = Await DoSsdpDiscoveryDialogAsync(location.Item1, location.Item2, progress)
If Not device Is Nothing Then devices.Add(device)
Next
Return devices.ToArray()
End Function
Async Function TestSsdpFromWin8Async(progress As IProgress(Of String)) As Task(Of MediaRendererDevice())
Dim remoteIp As New Windows.Networking.HostName("239.255.255.250"), remotePort = "1900" ' standard multicast address+port for SSDP
Dim reqbuf = System.Runtime.InteropServices.WindowsRuntime.WindowsRuntimeBufferExtensions.AsBuffer(CreateSsdpRequest(remoteIp.RawName() & ":" & remotePort))
Dim locations As New HashSet(Of Tuple(Of Uri, Uri))
Using socket As New Windows.Networking.Sockets.DatagramSocket()
AddHandler socket.MessageReceived,
Sub(sender, e)
If e.LocalAddress.IPInformation.NetworkAdapter.IanaInterfaceType = 24 Then Return ' loopback
' any loopback renderer will also report itself on the actual network, and I don't want to show duplicates
Using reader = e.GetDataReader()
Dim responsebuf = New Byte(CInt(reader.UnconsumedBufferLength - 1)) {}
reader.ReadBytes(responsebuf)
If Not progress Is Nothing Then progress.Report("Received from " & e.RemoteAddress.DisplayName & ":" & e.RemotePort & vbCrLf & Text.Encoding.UTF8.GetString(responsebuf, 0, responsebuf.Length))
Dim location = ParseSsdpResponse(responsebuf, responsebuf.Length)
If Not location Is Nothing Then locations.Add(Tuple.Create(location, New Uri("http://" & e.LocalAddress.CanonicalName)))
End Using
End Sub
' CAPABILITY: PrivateNetworks
Await socket.BindEndpointAsync(Nothing, "")
socket.Control.OutboundUnicastHopLimit = 1
socket.JoinMulticastGroup(remoteIp) ' Alas there's no WinRT equivalent of ReuseAddress
Using stream = Await socket.GetOutputStreamAsync(remoteIp, remotePort)
Await stream.WriteAsync(reqbuf)
Await Task.Delay(20)
Await stream.WriteAsync(reqbuf)
Await Task.Delay(20)
Await stream.WriteAsync(reqbuf)
End Using
Await Task.Delay(1200)
End Using
Dim devices As New List(Of MediaRendererDevice)
For Each location In locations
Dim device = Await DoSsdpDiscoveryDialogAsync(location.Item1, location.Item2, progress)
If Not device Is Nothing Then devices.Add(device)
Next
Return devices.ToArray()
End Function
Function CreateSsdpRequest(authority As String) As Byte()
Dim request = "M-SEARCH * HTTP/1.1" & vbCrLf &
"HOST: " & authority & vbCrLf &
"ST:urn:schemas-upnp-org:device:MediaRenderer:1" & vbCrLf &
"MAN: ""ssdp:discover""" & vbCrLf &
"MX: 1" & vbCrLf &
"" & vbCrLf
Return Text.Encoding.UTF8.GetBytes(request)
End Function
Function ParseSsdpResponse(responsebuf As Byte(), len As Integer) As Uri
Dim response = Text.Encoding.UTF8.GetString(responsebuf, 0, len)
Return (From line In response.Split({vbCr(0), vbLf(0)})
Where line.ToLowerInvariant().StartsWith("location:")
Select New Uri(line.Substring(9).Trim())).FirstOrDefault
End Function
Async Function DoSsdpDiscoveryDialogAsync(deviceLocation As Uri, localUri As Uri, progress As IProgress(Of String)) As Task(Of MediaRendererDevice)
Dim http As New Net.Http.HttpClient
Dim desc_request = MakeRawGetRequest(deviceLocation)
Dim desc_response = Await http.GetXmlAsync(desc_request, progress)
Dim desc_friendlyName = desc_response.<ud:root>.<ud:device>.<ud:friendlyName>.Value
Dim desc_services = desc_response.<ud:root>.<ud:device>.<ud:serviceList>.<ud:service>
Dim connectionManagerUri = (From service In desc_services Where service.<ud:serviceType>.Value = "urn:schemas-upnp-org:service:ConnectionManager:1" Select New Uri(deviceLocation, service.<ud:controlURL>.Value)).FirstOrDefault
Dim renderingControlUri = (From service In desc_services Where service.<ud:serviceType>.Value = "urn:schemas-upnp-org:service:RenderingControl:1" Select New Uri(deviceLocation, service.<ud:controlURL>.Value)).FirstOrDefault
Dim avTransportUri = (From service In desc_services Where service.<ud:serviceType>.Value = "urn:schemas-upnp-org:service:AVTransport:1" Select New Uri(deviceLocation, service.<ud:controlURL>.Value)).FirstOrDefault
If connectionManagerUri Is Nothing Then Return Nothing
Return New MediaRendererDevice With {.FriendlyName = desc_friendlyName, .LocalUri = localUri, .ConnectionManagerControlUrl = connectionManagerUri, .AVTransportControlUrl = avTransportUri}
End Function
Async Function TestUpnpFromConsoleAsync(device As MediaRendererDevice, progress As IProgress(Of String)) As Task
Dim data As New Net.Sockets.TcpListener(Net.IPAddress.Parse(device.LocalUri.DnsSafeHost), 0)
data.Start(1)
Dim dataTask = Task.Run(
Async Function()
While True
Using dataConnection = Await data.AcceptTcpClientAsync(), dataStream = dataConnection.GetStream()
Try
Await DoUpnpDataDialogAsync(dataStream, dataStream, progress)
Exit While
Catch ex As IO.IOException When ex.HResult = -2146232800
progress.Report(ex.Message)
' Why would a DigitalMediaRenderer open a data connection only to close it again immediately
' and reopen another one? I don't know, but we have to guard against it and offer the second opportunity.
End Try
End Using
End While
End Function)
Dim dataLocation = New Uri("http://" & data.Server.LocalEndPoint.ToString() & "/dummy.l16")
Await DoUPnPControlDialogAsync(device.ConnectionManagerControlUrl, device.AVTransportControlUrl, dataLocation, progress)
Await Task.Yield()
End Function
Async Function TestUpnpFromWin8Async(device As MediaRendererDevice, progress As IProgress(Of String)) As Task
Using data As New Windows.Networking.Sockets.StreamSocketListener()
AddHandler data.ConnectionReceived,
Async Sub(sender As Windows.Networking.Sockets.StreamSocketListener,
args As Windows.Networking.Sockets.StreamSocketListenerConnectionReceivedEventArgs)
Using args.Socket
Using data_reader = IO.WindowsRuntimeStreamExtensions.AsStreamForRead(args.Socket.InputStream),
data_writer = IO.WindowsRuntimeStreamExtensions.AsStreamForWrite(args.Socket.OutputStream)
Try
Await DoUpnpDataDialogAsync(data_writer, data_reader, progress)
Catch ex As Exception When ex.HResult = -2147014842
progress.Report(ex.Message)
' Why would a DigitalMediaRenderer open a data connection only to close it again immediately
' and reopen another one? I don't know, but we have to guard against it and offer the second opportunity.
End Try
End Using
End Using
End Sub
' CAPABILITY: privateNetworkClientServer
Await data.BindServiceNameAsync("")
Dim dataLocation = New Uri("http://" & device.LocalUri.Host & ":" & data.Information.LocalPort & "/stream.l16")
Await DoUPnPControlDialogAsync(device.ConnectionManagerControlUrl, device.AVTransportControlUrl, dataLocation, progress)
End Using
End Function
Async Function DoUPnPControlDialogAsync(connectionManagerUri As Uri, avTransportUri As Uri, dataLocation As Uri, progress As IProgress(Of String)) As Task
Dim http As New Net.Http.HttpClient()
Dim getprotocol_request = MakeRawSoapRequest(connectionManagerUri, <uc:GetProtocolInfo/>, {})
Dim getprotocol_response = Await http.GetSoapAsync(getprotocol_request, progress)
Dim getprotocol_sinks = getprotocol_response.<Sink>.Value.Split({","c}, StringSplitOptions.RemoveEmptyEntries)
For Each protocolInfo In getprotocol_sinks
Dim mimeType = protocolInfo.Split({":"c})(2)
If Not progress Is Nothing Then progress.Report(mimeType)
Next
Try
Dim stop_request = MakeRawSoapRequest(avTransportUri, <ut:Stop/>, {"InstanceID", "0"})
Dim stop_response = Await http.GetSoapAsync(stop_request, progress)
Catch ex As Net.Http.HttpRequestException ' Some devices give an http error code if you ask them to stop when they're already stopped
End Try
Dim seturi_request = MakeRawSoapRequest(avTransportUri, <ut:SetAVTransportURI/>, {"InstanceID", "0", "CurrentURI", dataLocation.ToString(), "CurrentURIMetaData", ""})
Dim seturi_response = Await http.GetSoapAsync(seturi_request, progress)
'
Dim play_request = MakeRawSoapRequest(avTransportUri, <ut:Play/>, {"InstanceID", "0", "Speed", "1"})
Dim play_response = Await http.GetSoapAsync(play_request, progress)
Dim warmupDelay = Task.Delay(1000)
While True
Dim transp_request = MakeRawSoapRequest(avTransportUri, <ut:GetTransportInfo/>, {"InstanceID", "0"})
Dim transp_response = Await http.GetSoapAsync(transp_request, Nothing)
Dim transp_state = transp_response.<CurrentTransportState>.Value
Dim transp_status = transp_response.<CurrentTransportStatus>.Value
'
Dim pos_request = MakeRawSoapRequest(avTransportUri, <ut:GetPositionInfo/>, {"InstanceID", "0"})
Dim pos_response = Await http.GetSoapAsync(pos_request, Nothing)
Dim pos_track = pos_response.<Track>.Value
Dim pos_trackuri = pos_response.<TrackURI>.Value
Dim pos_duration = pos_response.<TrackDuration>.Value
Dim pos_reltime = pos_response.<RelTime>.Value
Dim pos_relcount = pos_response.<RelCount>.Value
'
If Not progress Is Nothing Then progress.Report(String.Format("{0}/{1} - track#{2}, time={3}, count={4}", transp_state, transp_status, pos_track, pos_reltime, pos_relcount))
If transp_state = "STOPPED" AndAlso warmupDelay.IsCompleted Then Exit While ' for devices which take time to transition from "STOPPED"
'
Await Task.Delay(100)
End While
End Function
Async Function DoUpnpDataDialogAsync(writer As IO.Stream, reader As IO.Stream, progress As IProgress(Of String)) As Task
' Format of audio/L16 mime-type is described here: http://tools.ietf.org/html/rfc2586
Dim request = ""
Using sreader As New IO.StreamReader(reader, Text.Encoding.UTF8, False, 1024, True)
While True
Dim header = Await sreader.ReadLineAsync() : If String.IsNullOrWhiteSpace(header) Then Exit While
request &= header & vbCrLf
End While
End Using
progress.Report("#######################################################" & vbCrLf & request)
'
Dim response = "HTTP/1.1 200 OK" & vbCrLf & "Content-Type: audio/L16;rate=44100;channels=2" & vbCrLf & vbCrLf
Dim responsebuf = Text.Encoding.UTF8.GetBytes(response)
Await writer.WriteAsync(responsebuf, 0, responsebuf.Length)
'
Dim MaryHadALittleLamb = {247, 220, 196, 220, 247, 247, 247, 220, 220, 220, 247, 294, 294}
Dim phase = 0.0
Dim buf = New Byte(4096 * 4 - 1) {}
For imusic = 0 To MaryHadALittleLamb.Length * 8 - 1
Dim freq = If(imusic Mod 8 = 0, 0, MaryHadALittleLamb(imusic \ 8))
For i = 0 To buf.Length \ 4 - 1
phase += freq / 44100 * 2 * Math.PI
Dim amplitude = If(freq = 0, 0, Math.Sin(phase) * (Short.MaxValue - 1))
Dim bb = BitConverter.GetBytes(CShort(amplitude)) ' bb[0] is LSB, bb[1] is MSB, of this twos-complement signed short
buf(i * 4 + 0) = bb(1) ' left channel, MSB
buf(i * 4 + 1) = bb(0) ' left channel, LSB
buf(i * 4 + 2) = bb(1) ' right channel, MSB
buf(i * 4 + 3) = bb(0) ' right channel, LSB
Next
Await writer.WriteAsync(buf, 0, buf.Length)
progress.Report(freq.ToString() & "Hz")
Next
Await writer.FlushAsync()
End Function
Function MakeGetRequest(requestUri As Uri) As Net.Http.HttpRequestMessage
Return New Net.Http.HttpRequestMessage(Net.Http.HttpMethod.Get, requestUri)
End Function
Function MakeRawGetRequest(requestUri As Uri) As Tuple(Of Uri, Byte())
Dim s = "GET " & requestUri.PathAndQuery & " HTTP/1.1" & vbCrLf &
"Host: " & requestUri.Host & ":" & requestUri.Port & vbCrLf & vbCrLf
Return Tuple.Create(requestUri, Text.Encoding.UTF8.GetBytes(s))
End Function
Function MakeSoapRequest(requestUri As Uri, soapAction As XElement, args As String()) As Net.Http.HttpRequestMessage
Dim m As New Net.Http.HttpRequestMessage(Net.Http.HttpMethod.Post, requestUri)
m.Headers.Add("SOAPAction", """" & soapAction.Name.NamespaceName & "#" & soapAction.Name.LocalName & """")
Dim content = <?xml version="1.0"?>
<soap:Envelope soap:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<soap:Body>
<<%= soapAction.Name %>>
<%= Iterator Function()
For i = 0 To args.Length - 1 Step 2
Yield <<%= args(i) %>><%= args(i + 1) %></>
Next
End Function() %>
</>
</soap:Body>
</soap:Envelope>
m.Content = New Net.Http.StringContent(content.Declaration.ToString() & vbCrLf & content.ToString() & vbCrLf, Text.Encoding.UTF8, "text/xml")
Return m
End Function
Function MakeRawSoapRequest(requestUri As Uri, soapAction As XElement, args As String()) As Tuple(Of Uri, Byte())
Dim soapSchema = soapAction.Name.NamespaceName
Dim soapVerb = soapAction.Name.LocalName
Dim argpairs As New List(Of Tuple(Of String, String))
For i = 0 To args.Length - 1 Step 2 : argpairs.Add(Tuple.Create(args(i), args(i + 1))) : Next
' Format of how to make UPnP SOAP requests is described here: http://upnp.org/specs/arch/UPnP-arch-DeviceArchitecture-v1.0.pdf
Dim s = "POST " & requestUri.PathAndQuery & " HTTP/1.1" & vbCrLf &
"Host: " & requestUri.Authority & vbCrLf &
"Content-Length: ?" & vbCrLf &
"Content-Type: text/xml; charset=""utf-8""" & vbCrLf &
"SOAPAction: """ & soapSchema & "#" & soapVerb & """" & vbCrLf &
"" & vbCrLf &
"<?xml version=""1.0""?>" & vbCrLf &
"<s:Envelope xmlns:s=""http://schemas.xmlsoap.org/soap/envelope/"" s:encodingStyle=""http://schemas.xmlsoap.org/soap/encoding/"">" & vbCrLf &
" <s:Body>" & vbCrLf &
" <u:" & soapVerb & " xmlns:u=""" & soapSchema & """>" & vbCrLf &
String.Join(vbCrLf, (From arg In argpairs Select " <" & arg.Item1 & ">" & arg.Item2 & "</" & arg.Item1 & ">").Concat({""})) &
" </u:" & soapVerb & ">" & vbCrLf &
" </s:Body>" & vbCrLf &
"</s:Envelope>" & vbCrLf
'
Dim len = Text.Encoding.UTF8.GetByteCount(s.Substring(s.IndexOf("<?xml")))
s = s.Replace("Content-Length: ?", "Content-Length: " & len)
Return tuple.Create(requestUri, Text.Encoding.UTF8.GetBytes(s))
End Function
<Runtime.CompilerServices.Extension>
Async Function GetXmlAsync(http As Net.Http.HttpClient, request As Net.Http.HttpRequestMessage, Optional progress As IProgress(Of String) = Nothing) As Task(Of XDocument)
If Not progress Is Nothing Then progress.Report("--------->" & vbCrLf & request.ToString())
Using response = Await http.SendAsync(request)
response.EnsureSuccessStatusCode()
' Work around ugly bug in HttpClient.GetStringAsync / HttpContent.ReadAsStringAsync...
If Not response.Content.Headers.ContentType.CharSet Is Nothing Then response.Content.Headers.ContentType.CharSet = response.Content.Headers.ContentType.CharSet.Trim(""""c)
Dim body = Await response.Content.ReadAsStringAsync()
If Not progress Is Nothing Then progress.Report(String.Join(vbCrLf & " ", (vbCrLf & "<--------" & vbCrLf & response.Content.Headers.ToString() & vbCrLf & body).Split({vbCrLf}, StringSplitOptions.None)))
Return XDocument.Parse(body)
End Using
End Function
<Runtime.CompilerServices.Extension>
Async Function GetXmlAsync(http As Net.Http.HttpClient, request As Tuple(Of Uri, Byte()), Optional progress As IProgress(Of String) = Nothing) As Task(Of XDocument)
' HttpClient doesn't expose any way to send the raw request, so we'll do it ourselves
'
Dim requestUri = request.Item1, requestBody = request.Item2
If Not progress Is Nothing Then progress.Report("---------> " & requestUri.DnsSafeHost & ":" & requestUri.Port & vbCrLf & Text.Encoding.UTF8.GetString(requestBody))
Using socket As New Net.Sockets.TcpClient(requestUri.DnsSafeHost, requestUri.Port), stream = socket.GetStream()
Await stream.WriteAsync(requestBody, 0, requestBody.Length)
Await stream.FlushAsync()
'
Dim headers = "", body = ""
Using sreader As New IO.StreamReader(stream, Text.Encoding.UTF8, False, 1024, True)
Dim len = 0
While True
Dim header = Await sreader.ReadLineAsync()
If String.IsNullOrWhiteSpace(header) Then Exit While
If header.ToLower().StartsWith("content-length:") Then len = CInt(header.Substring(15).Trim())
headers &= header & vbCrLf
End While
Dim buf = New Char(1024) {}
While Text.Encoding.UTF8.GetByteCount(body) < len
Dim red = Await sreader.ReadAsync(buf, 0, 1024)
body &= New String(buf, 0, red)
End While
End Using
'
If Not progress Is Nothing Then progress.Report(String.Join(vbCrLf & " ", (vbCrLf & "<--------" & vbCrLf & headers & vbCrLf & body).Split({vbCrLf}, StringSplitOptions.None)))
If Not headers.StartsWith("HTTP/1.1 200 OK") Then
Throw New Net.Http.HttpRequestException(headers & vbCrLf & body)
End If
Return XDocument.Parse(body)
End Using
End Function
<Runtime.CompilerServices.Extension>
Async Function GetSoapAsync(http As Net.Http.HttpClient, request As Net.Http.HttpRequestMessage, Optional progress As IProgress(Of String) = Nothing) As Task(Of XElement)
Dim soapAction = request.Headers.GetValues("SOAPAction").FirstOrDefault.Trim(""""c) ' e.g. schema#action
Dim soapResponse As Xml.Linq.XName = "{" & soapAction.Replace("#", "}") & "Response" ' e.g. {schema}actionResponse
'
Dim xml = Await GetXmlAsync(http, request, progress)
Dim body = xml.<soap:Envelope>.<soap:Body>.Elements(soapResponse).FirstOrDefault
If body Is Nothing Then Throw New Net.Http.HttpRequestException("no soap body")
Return body
End Function
<Runtime.CompilerServices.Extension>
Async Function GetSoapAsync(http As Net.Http.HttpClient, request As Tuple(Of Uri, Byte()), Optional progress As IProgress(Of String) = Nothing) As Task(Of XElement)
Dim requestLines = Text.Encoding.UTF8.GetString(request.Item2).Split({vbCrLf}, StringSplitOptions.None)
Dim soapAction = (From s In requestLines Where s.ToLower().StartsWith("soapaction:")).FirstOrDefault.Substring(11).Trim(" "c, """"c)
Dim soapResponse As Xml.Linq.XName = "{" & soapAction.Replace("#", "}") & "Response" ' e.g. {schema}actionResponse
'
Dim xml = Await GetXmlAsync(http, request, progress)
Dim body = xml.<soap:Envelope>.<soap:Body>.Elements(soapResponse).FirstOrDefault
If body Is Nothing Then Throw New Net.Http.HttpRequestException("no soap body")
Return body
End Function
End Module
Submit an article or tip