Click here to Skip to main content
10,500,000 members (35,753 online)
Click here to Skip to main content

Stats

68.8K views
2.1K downloads
33 bookmarked
Posted 13 Sep 2012

UPnP code for Windows 8

, 13 Sep 2012
How to use UPnP on Windows 8
´╗┐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

By viewing downloads associated with this article you agree to the Terms of Service and the article's licence.

If a file you wish to view isn't highlighted, and is a text file (not binary), please let us know and we'll add colourisation support for it.

License

This article, along with any associated source code and files, is licensed under A Public Domain dedication

Share

About the Author

ljw1004
Technical Lead
United States United States
Lucian studied theoretical computer science in Cambridge and Bologna, and then moved into the computer industry. Since 2004 he's been paid to do what he loves -- designing and implementing programming languages! The articles he writes on CodeProject are entirely his own personal hobby work, and do not represent the position or guidance of the company he works for. (He's on the VB/C# language team at Microsoft).

You may also be interested in...

Pro
Permalink | Advertise | Privacy | Terms of Use | Mobile
Web04 | 2.8.170924.2 | Last Updated 14 Sep 2012
Article Copyright 2012 by ljw1004
Everything else Copyright © CodeProject, 1999-2017
Layout: fixed | fluid