Ssdp.fs

module Ssdp

open System
open System.Net
open System.Text
open System.Net.Sockets

///
/// SSDP protocol types.  Not complete as only adding when happy with design.
///
type SearchTarget = All | RootDevices
type DeviceResponseDelay = OneSecond | TwoSeconds | ThreeSeconds | FourSeconds | FiveSeconds
type MSearch = { SearchTarget:SearchTarget; DeviceResponseDelay:DeviceResponseDelay; }
type DeviceNotification = Available | Unavailable | Updated

/// Reveal F#s secret Agent!
type private Agent<'T> = MailboxProcessor<'T>

/// Extensions to the UdpClient.  HT @jonharrop.
type private Sockets.UdpClient with
    member client.AsyncSend(bytes, length, ep) =
        let beginSend(f, o) = client.BeginSend(bytes, length, ep, f, o)
        Async.FromBeginEnd(beginSend, client.EndSend)

    member client.AsyncReceive() =
        async { let ep = ref null 
                let endRecv res = client.EndReceive(res, ep)
                let! bytes = Async.FromBeginEnd(client.BeginReceive, endRecv)
                return bytes, !ep }

    ///Close and ignore any Exceptions.
    member client.ProtectedClose() =
        //TODO this is dirty.  Make it better.
        try client.Close() with | :? SocketException -> () | :? ObjectDisposedException -> () 

// Message types for the listener controller agent. 
type private Port = int
type private ListenerController =
    | ListenForSearchResponsesAndNotifyAdverts of Port * IPAddress seq
    | StopListening

///
/// Represents an SSDP Discovery Session.
/// Create one and ask it to do searches, or just listen to notifications.
/// Search responses and notifications are all fired as events.
///
type Session private (port) =

    let messageReceivedEvent = Event<_>()
    let multicastIPEndpoint = IPEndPoint(IPAddress.Parse("239.255.255.250"), 1900)

    let udpClientReceiveLoopAsync (client:UdpClient) = async {
        while true do
            let! msgBytes, _ = client.AsyncReceive()
            let msg = String(Text.UTF8Encoding.UTF8.GetChars(msgBytes))
            //TODO enable this event to fire on caller thread.
            //TODO actually parse the message to a type.  String just for now.
            messageReceivedEvent.Trigger(msg)
    }

    let createMulticastClient (ip:IPAddress) = 
        let udpClient = new Sockets.UdpClient(IPEndPoint(ip, 1900))
        udpClient.Client.SetSocketOption(SocketOptionLevel.Socket, SocketOptionName.ReuseAddress, true)
        udpClient.JoinMulticastGroup(multicastIPEndpoint.Address)
        udpClient

    let createUnicastClient (port:int, ip:IPAddress) = 
        let udpClient = new Sockets.UdpClient ()
        udpClient.Client.SetSocketOption(SocketOptionLevel.Socket, SocketOptionName.ReuseAddress, true)
        udpClient.Client.Bind(IPEndPoint(ip, port))
        udpClient

    /// Agent that spins up listeners for us.  We have this agent indirection step, so that
    /// if the NIC ips change during the session, a message can be posted to this agent
    /// and it can spin up new listeners.  I took this approach to avoid mutation
    /// in this class.  Is there a more idiomatic way to do this kind of thing? 
    let udpClientListeningController = Agent.Start(fun inbox -> 
        let rec loop (runningClients:UdpClient seq) = async {
            let! msg = inbox.Receive()
            runningClients |> Seq.iter (fun client -> client.ProtectedClose())
            match msg with
            | ListenForSearchResponsesAndNotifyAdverts (port, ipAddresses) ->
                let udpClients =
                  [ for ip in ipAddresses do
                      yield createUnicastClient(port, ip)
                      yield createMulticastClient(ip) ]
                //Start em up.
                udpClients |> Seq.iter (udpClientReceiveLoopAsync >> Async.Start)
                return! loop udpClients
            | StopListening -> return! loop Seq.empty
        }
        loop Seq.empty 
    )

    let upnpIpAddresses () =
        //TODO support IPV6 as per UPnP spec.  Only v4 for now.
        let ipVFourFilter (ipAddress:IPAddress) = ipAddress.AddressFamily = AddressFamily.InterNetwork 
        let allIps = Dns.GetHostEntry(Dns.GetHostName()).AddressList
        allIps |> Seq.filter ipVFourFilter

    do
        //Start listening and also setup to re-start listening if NIC IP changes.
        let listen () =
            udpClientListeningController.Post(ListenForSearchResponsesAndNotifyAdverts(port, upnpIpAddresses()))
        listen ()
        Net.NetworkInformation.NetworkChange.NetworkAddressChanged.Add(fun x -> listen())
        
    /// Create an SSDP Session.  Start listening for notifications immediately.
    /// Broadcast from the specified port and unicast receive on that port too.
    static member Start(port:int) = Session(port)

    [<CLIEvent>]
    /// Fired when a search response or notification message is received.
    member x.MessageReceived = messageReceivedEvent.Publish

    /// Do a search for network devices.
    member x.BroadcastMSearch(search) =

        /// Create a search byte array from an MSearch.
        let searchMessageBytes = 

            let delaySeconds = 
                match search.DeviceResponseDelay with
                | OneSecond -> 1
                | TwoSeconds -> 2
                | ThreeSeconds -> 3
                | FourSeconds -> 4
                | FiveSeconds -> 5
            
            let searchTarget = 
                match search.SearchTarget with
                | All -> "ssdp:all"
                | RootDevices -> "upnp:rootdevice"

            let msg =
                (sprintf "M-SEARCH * HTTP/1.1\n\
                         ST: %s\n\
                         MAN: \"ssdp:discover\"\n\
                         HOST: 239.255.255.250:1900\n\
                         MX: %i\n" searchTarget delaySeconds)

            UTF8Encoding.UTF8.GetBytes(msg)

        /// Multicast the search message on each local ip (IPv4 and v6 for example).
        for ip in upnpIpAddresses () do
            //TODO can we support NAT?
            let udp = new Sockets.UdpClient (EnableBroadcast = true)
            udp.Client.SetSocketOption(SocketOptionLevel.Socket, SocketOptionName.ReuseAddress, true)
            udp.Client.Bind(IPEndPoint(ip, port))
            udp.JoinMulticastGroup(multicastIPEndpoint.Address)
            udp.AsyncSend (searchMessageBytes, searchMessageBytes.Length, multicastIPEndpoint)
            |> Async.RunSynchronously |> ignore
            //TODO spec says issue search more than once as Upnp not reliable.
            //Perhaps set to do second search after delay on another thread.
        ()

Usage.fs

//Fire up a session.
let ssdpSession = Ssdp.Session.Start(1985)

//Startlistening 
ssdpSession.MessageReceived.Add(fun msg -> printfn "%s" msg)

//Do an MSearch.
let search = { MSearch.SearchTarget = All; DeviceResponseDelay = OneSecond; }
ssdpSession.BroadcastMSearch(search)