Artifact Content
Not logged in

Artifact 2bdf5c1dcb963a08b355004a95e6ff01b23be233:


namespace eval ssdp {
    package require udp

    # IANA assigned UPnP multicast address and port
    variable addr 239.255.255.250 port 1900

    variable refresh 180 ttl 4 if ""

    # Default user agent
    variable agent [format {%s/%s UPnP/1.1 Tcl/%s} \
      $tcl_platform(os) $tcl_platform(osVersion) [info patchlevel]]

    variable provider {} device {} listeners {} ingroup 0

    namespace ensemble create -subcommands {
	agent detection provide search remove rejoin
    }
}

proc ssdp::log {str} {
    # Provide custom implementation to get debugging output
    # puts $str
}

proc ssdp::init {} {
    variable addr
    variable port
    variable ingroup
    # The reuse option will allow multiple apps to listen on the same UDP port.
    # This option was introduced in udp 1.0.9, but it doesn't generate an error
    # in older version of the package
    if {[catch {udp_open $port reuse} result]} {
	# Some other UPnP application has already claimed the ssdp port
	error "can't open ssdp port" $result $::errorCode
    }
    variable fd $result
    # Join the multicast group
    if {![catch {fconfigure $fd -mcastadd $addr}]} {
	set ingroup 1
    }
    # Using "-buffering none" has the undesired side-effect that the implied
    # newline of the puts command gets sent in a separate UDP package.
    fconfigure $fd -blocking 0 -translation {auto crlf} -mcastloop 1
    fileevent $fd readable [namespace code [list receive $fd]]
}

proc ssdp::agent {} {
    variable agent
    return $agent
}

# Normalize a UUID so all allowed versions look the same
proc ssdp::normalize {str} {
    set hex [string tolower [string map {- ""} $str]]
    if {[string length $hex] != 32} {return $hex}
    return [join [scan $hex %8s%4s%4s%4s%12s] -]
}

# Device is no longer available
proc ssdp::expire {uuid} {
    variable device
    if {[dict exists $device $uuid afterid]} {
	# Cancel any running timer
	after cancel [dict get $device $uuid afterid]
	foreach n [dict keys [dict get $device $uuid] urn:*] {
	    alert byebye $n $uuid
	}
	alert byebye $uuid $uuid
	alert byebye upnp:rootdevice $uuid
    }
    dict unset device $uuid
}

# Process received ssdp messages
proc ssdp::receive {fd} {
    set data [read $fd]
    # Discard false triggers
    if {$data eq ""} return

    set peer [fconfigure $fd -peer]
    upvar #0 buffer($peer) buf
    log "Received [string length $data] bytes from [join $peer :]:\n$data\n"
    append buf $data
    set x [string first \n\n $buf]
    if {$x < 0} return
    set head [lassign [split [string range $buf 0 [expr {$x - 1}]] \n] start]
    set buf [string range $buf [expr {$x + 2}] end]

    # Parse the message
    foreach n $head {
	set x [string first : $n]
	if {$x < 0} return
	set name [string trim [string replace $n $x end]]
	set value [string trim [string replace $n 0 $x]]
	dict set hdrs [string tolower $name] $value
    }

    if {$start eq {M-SEARCH * HTTP/1.1}} {
	if {[dict exists $hdrs st]} {
	    locate $peer [dict get $hdrs st]
	}
	return
    }

    # Other messages must have a USN header
    if {![dict exists $hdrs usn]} return

    # Extract the uuid
    if {[scan [dict get $hdrs usn] {uuid:%[0-9a-fA-F-]} uuid] == 1} {
	set uuid [normalize $uuid]
    } elseif {[scan [dict get $hdrs usn] {uuid:%[^:]} uuid] != 1} {
	# Didn't find a uuid
	return
    }

    if {$start eq {NOTIFY * HTTP/1.1}} {
	# Notify message must have a NTS header
	if {![dict exists $hdrs nts]} return
	# Devices going away
	if {[dict get $hdrs nts] eq "ssdp:byebye"} {
	    expire $uuid
	    return
	}
	# Get the target from the NT header
	if {![dict exists $hdrs nt]} return
	set target [dict get $hdrs nt]
    } elseif {$start eq {HTTP/1.1 200 OK}} {
	# Get the target from the ST header
	if {![dict exists $hdrs st]} return
	set target [dict get $hdrs st]
    }

    # Message must have a LOCATION header
    if {![dict exists $hdrs location]} return

    # Message must have a CACHE-CONTROL header
    if {![dict exists $hdrs cache-control]} return

    # Check the CACHE-CONTROL header is valid
    if {[scan [dict get $hdrs cache-control] {max-age=%d} sec] != 1} return

    # Store the received information
    store $uuid $target [dict get $hdrs location] $sec
}

proc ssdp::store {uuid target loc expire} {
    variable device

    # Refresh the availability
    if {[dict exists $device $uuid afterid]} {
	after cancel [dict get $device $uuid afterid]
    }
    set id [after [expr {$expire * 1000}] [namespace code [list expire $uuid]]]
    dict set device $uuid afterid $id

    # Keep track of the target
    if {[dict exists $device $uuid $target] && \
      [dict get $device $uuid $target] eq $loc} {
	set event alive
    } else {
	dict set device $uuid $target $loc
	set event update
    }

    alert $event $target $uuid $loc
}

proc ssdp::alert {event target uuid args} {
    # Check if there are any interested parties
    variable listeners
    set keys {}
    if {[string match {urn:*:*:*:*} $target]} {
	set x [string last : $target]
	set pattern [string range $target 0 $x]*
	set version [string range $target [incr x] end]
	foreach n [dict keys $listeners $pattern] {
	    if {[string range $n $x end] <= $version} {
		lappend keys $n
	    }
	}
    } elseif {[dict exists $listeners $target]} {
	lappend keys $target
    }
    foreach n $keys {
	dict update listeners $n list {
	    dict for {cmdpfx done} $list {
		if {$uuid ni $done} {
		    dict lappend list $cmdpfx $uuid
		} elseif {$event eq "alive"} {
		    continue
		}
		after idle [linsert $cmdpfx end $event $target $uuid {*}$args]
	    }
	}
    }
}

proc ssdp::satisfies {provided requested} {
    if {$provided eq $requested} {return true}
    set x [string last : $provided]    
    if {![string equal -length [incr x] $provided $requested]} {return false}
    set ver1 [string range $provided $x end]
    set ver2 [string range $requested $x end]
    return [expr {$ver1 >= $ver2}]
}

proc ssdp::locate {peer spec} {
    variable provider
    # Specification can be all, rootdevices, a uuid, a device, or a service
    switch -glob $spec {
	ssdp:all {
	    set devtest true
	    set svctest {[dict exists $info services]}
	    set devtype {root uuid name}
	}
	upnp:rootdevice {
	    set devtest {[dict get $info parent] eq ""}
	    set svctest false
	    set devtype root
	}
	uuid:* {
	    set str [string range $spec 5 end]
	    set devtest {[dict get $info uuid] eq $str}
	    set svctest false
	    set devtype uuid
	}
	urn:*:device:*:* {
	    set devtest {[satisfies $device $spec]}
	    set svctest false
	    set devtype name
	}
	urn:*:service:*:* {
	    set devtest false
	    set svctest {[dict exists $info services]}
	}
    }
    dict for {device info} $provider {
	set uuid [dict get $info uuid]
	if $devtest {
	    set url [dict get $info url]
	    if {"root" in $devtype && [dict get $info parent] eq ""} {
		respond $peer upnp:rootdevice $uuid $url
	    }
	    if {"uuid" in $devtype} {
		respond $peer $uuid $uuid $url
	    }
	    if {"name" in $devtype} {
		respond $peer $device $uuid $url
	    }
	}
	if $svctest {
	    set services [dict get $info services]
	    if {$spec eq "ssdp:all"} {
		dict for {name loc} $services {
		    respond $peer $name $uuid $loc
		}
	    } else {
		dict for {name loc} $services {
		    if {[satisfies $name $spec]} {
			respond $peer $spec $uuid $loc
		    }
		}
	    }
	}
    }
}

proc ssdp::respond {peer target uuid loc} {
    variable fd; variable agent; variable refresh
    set msg [list "HTTP/1.1 200 OK"]
    lappend msg "LOCATION: $loc"
    lappend msg "SERVER: $agent"
    lappend msg "CACHE-CONTROL: max-age=$refresh"
    lappend msg "EXT:"
    lappend msg "ST: $target"
    if {$target ne $uuid} {
	lappend msg "USN: uuid:${uuid}::${target}"
    } else {
	lappend msg "USN: uuid:$uuid"
    }
    lappend msg ""

    fconfigure $fd -remote $peer
    try {
	puts $fd [join $msg \n]
	flush $fd
    } trap {POSIX ENETUNREACH} {} {
    }
}

# Broadcast the message repeatedly
proc ssdp::broadcast {fd msg {count 1} {delay 400}} {
    variable addr; variable port; variable if
    fconfigure $fd -remote [list $addr $port] -ttl 4 -translation crlf
    try {
	puts $fd $msg
	flush $fd
    } trap {POSIX ENETUNREACH} {} {
    }
    if {[incr count -1] > 0} {
	after $delay [namespace code [list broadcast $fd $msg $count $delay]]
    }
}

# Very simple uuid generator. Use the uuid package from tcllib if possible
proc ssdp::uuid {} {
    if {![catch {package require uuid}]} {
	set uuid [::uuid::uuid generate]
    } else {
	set s [socket -server {} -myaddr [info hostname] 0]
	set part1 [split [lindex [fconfigure $s -sockname] 0] .]
	close $s
	set part2 [pid]
	set part3 [expr {int(4096 * rand()) | 0x4000}]
	set part4 [expr {int(16384 * rand()) | 0x8000}]
	set part5 [expr {[clock microseconds] & 0xffffffffffff}]
	set uuid [format %02x%02x%02x%02x-%04x-%04x-%04x-%012x \
	  {*}$part1 $part2 $part3 $part4 $part5]
    }
    return $uuid
}

proc ssdp::rejoin {} {
    variable addr; variable fd; variable ingroup
    if {$ingroup} {
	catch {
	    if {![string match "wifi*" [borg networkinfo]]} {
		set ingroup 0
	    }
	}
	if {!$ingroup} {
	    catch {fconfigure $fd -mcastdel $addr}
	}
    } else {
	if {![catch {fconfigure $fd -mcastadd $addr}]} {
	    set ingroup 1
	}
    }
}

proc ssdp::search {target {mx 1} {repeat 2}} {
    variable addr; variable port; variable agent; variable if
    rejoin
    # Create a temporary socket because some clients won't respond to search
    # requests from port 1900 for some strange reason
    set fd [udp_open]
    # Requires tcludp 1.0.10 + patch by Sean Woods.
    if {$if ne ""} {fconfigure $fd -mcastif $if}
    fileevent $fd readable [namespace code [list receive $fd]]
    set msg [list "M-SEARCH * HTTP/1.1"]
    lappend msg "HOST: $addr:$port"
    lappend msg {MAN: "ssdp:discover"}
    lappend msg "MX: $mx"
    lappend msg "ST: $target"
    lappend msg "USER-AGENT: $agent"
    lappend msg ""
    # UDP messages may be lost, so send it several times
    broadcast $fd [join $msg \n] $repeat
    # Clean up the temporary socket when it's no longer needed
    after [expr {1000 * ($mx + 2)}] [list close $fd]
}

proc ssdp::notify {target uuid subtype {location ""}} {
    variable addr; variable port; variable agent; variable fd; variable refresh
    set msg [list "NOTIFY * HTTP/1.1"]
    lappend msg "HOST: $addr:$port"
    if {$subtype eq "ssdp:alive"} {
	lappend msg "CACHE-CONTROL: max-age=$refresh"
	lappend msg "LOCATION: $location"
	lappend msg "NT: $target"
	lappend msg "NTS: $subtype"
	lappend msg "USER-AGENT: $agent"
    } elseif {$subtype eq "ssdp:byebye"} {
	lappend msg "NT: $target"
	lappend msg "NTS: $subtype"
    } elseif {$subtype eq "ssdp:update"} {
	lappend msg "LOCATION: $location"
	lappend msg "NT: $target"
	lappend msg "NTS: $subtype"
    } else {
	error "unknown subtype: $subtype"
    }
    if {$uuid eq $target} {
	lappend msg "USN: uuid:$uuid"
    } else {
	lappend msg "USN: uuid:${uuid}::${target}"
    }
    lappend msg ""
    # Transmit the message
    rejoin
    broadcast $fd [join $msg \n]
}

# uuid:75802409-bccb-40e7-8e6c-0024FEE6DA60::upnp:rootdevice
# uuid:75802409-bccb-40e7-8e6c-0024FEE6DA60::urn:schemas-upnp-org:device:InternetGatewayDevice:1
# uuid:75802409-bccb-40e7-8e6c-0024FEE6DA60::urn:schemas-any-com:service:Any:1
# uuid:75802409-bccb-40e7-8e6b-0024FEE6DA60::urn:schemas-upnp-org:device:WANDevice:1
# uuid:75802409-bccb-40e7-8e6b-0024FEE6DA60::urn:schemas-upnp-org:service:WANCommonInterfaceConfig:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:device:WANConnectionDevice:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:service:WANDSLLinkConfig:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:service:WANIPConnection:1

proc ssdp::provide {struct} {
    set host [dict get $struct host]
    set port [dict get $struct port]
    set loc [dict get $struct location]
    set url http://$host:$port/$loc
    device $url $struct {}

    set cmd [namespace code advertise]
    after cancel $cmd
    # "Devices SHOULD wait a random interval (e.g. between 0 and
    # 100milliseconds) before sending an initial set of advertisements
    # in order to reduce the likelihood of network storms"
    after [expr {round(100 * rand())}] $cmd
}

proc ssdp::device {url struct parent} {
    variable provider
    set name [dict get $struct name]
    set new [dict filter $struct script {key val} {
	expr {$key in {url uuid services}}
    }]
    dict set new url $url
    dict set new parent $parent
    if {![dict exists $new uuid]} {dict set new uuid [uuid]}
    dict set provider $name $new
    if {[dict exists $struct devices]} {
	foreach n [dict get $struct devices] {
	    dict lappend new embedded [device $url $n $name]
	}
    }
    return [dict get $new uuid]
}

proc ssdp::advertise {{subtype ssdp:alive}} {
    variable provider
    dict for {device info} $provider {
	set uuid [dict get $info uuid]
	set url [dict get $info url]
	if {[dict get $info parent] eq ""} {
	    notify upnp:rootdevice $uuid $subtype $url
	}
	notify $uuid $uuid $subtype $url
	notify $device $uuid $subtype $url
	if {[dict exists $info services]} {
	    set url [dict get $info url]
	    foreach name [dict keys [dict get $info services]] {
		notify $name $uuid $subtype $url
	    }
	}
    }
    after cancel [namespace code advertise]
    # Refresh the bindings after a little under 1/3 of the max-age value so
    # there are 3 chances for the UDP messages to arrive at their destination
    if {$subtype eq "ssdp:alive"} {
	variable refresh
	after [expr {300 * $refresh}] [namespace code advertise]
    }
}

proc ssdp::detection {op target cmdpfx} {
    variable listeners
    if {$op eq "add"} {
	dict set listeners $target $cmdpfx {}
    } elseif {$op eq "remove"} {
	dict unset listeners $target $cmdpfx
    }
}

proc ssdp::remove {} {
    advertise ssdp:byebye
}

ssdp::init