package require ssdp
package require http
package require tdom
namespace eval upnp {
variable service "" port "" discover ""
namespace ensemble create -subcommands {discover advertise revoke}
}
proc upnp::geturl {url args} {
set coro [info coroutine]
if {$coro ne ""} {
::http::geturl $url {*}$args -command $coro
return [yield]
} else {
return [::http::geturl $url {*}$args]
}
}
proc upnp::urljoin {base path} {
if {[string index $path 0] eq "/"} {
set start [expr {[string first :// $base] + 3}]
set x [string first / $base $start]
} elseif {[string first :// $path] < 0} {
set x [expr {[string last / $base] + 1}]
} else {
# Path already is a fully qualified URL
return $path
}
return [string replace $base $x end $path]
}
proc upnp::trigger {cmdpfx event name uuid {url ""}} {
variable service
if {$event in {alive update}} {
set tok [http::geturl $url \
-command [namespace code [list alive $cmdpfx $uuid $url]]]
} elseif {$event eq "byebye"} {
# Clean up
if {[namespace exists ::$uuid]} {
namespace delete ::$uuid
}
dict unset service $uuid
}
}
proc upnp::alive {cmdpfx uuid base tok} {
if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} {
variable service
dom parse [http::data $tok] doc
http::cleanup $tok
dict set service $uuid command $cmdpfx
$doc documentElement root
$doc selectNodesNamespaces [list ns [$root namespaceURI]]
device $root $base $cmdpfx
} else {
puts "http geturl failed."
http::cleanup $tok
}
}
proc upnp::device {doc base cmdpfx} {
foreach dev [$doc selectNodes ns:device] {
scan [$dev selectNodes string(ns:UDN)] {uuid:%s} uuid
namespace eval ::$uuid {
proc url {str} {
variable base
tailcall ::upnp::urljoin $base $str
}
}
namespace upvar ::$uuid info info icon icon base baseurl
set icon ""
set baseurl $base
foreach n [$dev childNodes] {
set str [$n nodeName]
switch -- $str {
friendlyName - manufacturer - manufacturerURL -
modelDescription - modelName - modelNumber -
modelURL - serialNumber - presentationURL {
dict set info $str [$n text]
}
iconList {
set icon [iconlist $base $n]
}
serviceList {
variable service
foreach svc [$n selectNodes ns:service] {
set type [$svc selectNodes string(ns:serviceType)]
set name [$svc selectNodes string(ns:serviceId)]
set scpd [$svc selectNodes string(ns:SCPDURL)]
set ctrl [$svc selectNodes string(ns:controlURL)]
set evnt [$svc selectNodes string(ns:eventSubURL)]
set tok [http::geturl [urljoin $base $scpd] \
-command [namespace code [list service $uuid]]]
regsub {.*:} $name "" name
dict update service $uuid self {
dict set self tokens $tok $name
dict set self $name control [urljoin $base $ctrl]
dict set self $name event [urljoin $base $evnt]
dict set self $name service $type
}
}
}
}
}
}
}
proc upnp::service {uuid tok} {
variable service
try {
set ns [dict get $service $uuid tokens $tok]
namespace eval ::${uuid}::${ns} {}
dict unset service $uuid tokens $tok
if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} {
set data [http::data $tok]
http::cleanup $tok
binary scan $data H6 hex
if {$hex eq "efbbbf"} {
# UTF8 BOM found
set data [encoding convertfrom utf-8 $data]
}
dom parse $data doc
$doc documentElement root
$doc selectNodesNamespaces [list ns [$root namespaceURI]]
foreach act [$root selectNodes //ns:actionList/ns:action] {
set action [[$act selectNodes ns:name] text]
set proc ::${uuid}::${ns}::${action}
set cmd [namespace current]::control
lappend cmd [dict get $service $uuid $ns service]
lappend cmd [dict get $service $uuid $ns control] $action
set args {}
foreach arg [$act selectNodes ns:argumentList/ns:argument] {
set argument [[$arg selectNodes ns:name] text]
set dir [[$arg selectNodes ns:direction] text]
if {$dir eq "in"} {
lappend args $argument
}
}
lappend cmd $args
proc $proc args [format {%s $args} $cmd]
}
} else {
puts [http::code $tok]
http::cleanup $tok
}
if {[dict size [dict get $service $uuid tokens]] == 0} {
dict unset service $uuid tokens
set cmdpfx [dict get $service $uuid command]
uplevel #0 [linsert $cmdpfx end $uuid]
}
} on error {err info} {
puts [dict get $info -errorinfo]
}
}
proc upnp::iconlist {base doc} {
set rc {}
foreach node [$doc childNodes] {
foreach n [$node childNodes] {
dict set icon [$n nodeName] [$n text]
}
dict with icon {
set size [format %sx%sx%s $width $height $depth]
dict set rc $mimetype $size [urljoin $base $url]
}
}
return $rc
}
proc upnp::discover {spec {cmdpfx ""}} {
variable discover
if {$cmdpfx ne ""} {
dict set discover $spec $cmdpfx
ssdp detection add $spec [namespace code [list trigger $cmdpfx]]
ssdp search $spec 1
} elseif {[dict exists $discover $spec]} {
set cmdpfx [dict get $discover $spec]
if {[llength [info level 0]] < 3} {return $cmdpfx}
ssdp detection remove $spec [namespace code [list trigger $cmdpfx]]
dict unset discover $spec
}
}
proc upnp::control {service url name argnames argvals} {
set nss http://schemas.xmlsoap.org/soap/envelope/
set soap [soap $service $name $argnames $argvals]
lappend hdrs SOAPACTION [format {"%s"} $service#$name]
http::config -useragent [ssdp agent]
set tok [geturl $url -type text/xml -headers $hdrs -query $soap]
set rc {}
if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} {
dom parse [http::data $tok] doc
http::cleanup $tok
$doc selectNodesNamespaces [list s $nss u $service]
set res [$doc selectNodes /s:Envelope/s:Body/u:${name}Response]
foreach n [$res childNodes] {
dict set rc [$n nodeName] [$n text]
}
} else {
http::cleanup $tok
}
return $rc
}
proc upnp::advertise {specfile {base ""}} {
# Parse the specification file, errors should be handled by the caller
set fd [open $specfile]
try {
dom parse [read $fd] doc
} finally {
close $fd
}
$doc selectNodesNamespaces {ns urn:schemas-upnp-org:device-1-0}
set dict [makedev [$doc selectNodes /ns:root/ns:device]]
# Load wibble, if necessary
package require wibble
# Use a different port for each root device to avoid conflicts
# Pick a port by opening a listening socket. Can't let wibble figure out
# a port by itself because then it will not be in the state variable
# At the same time figure out our local IP address
set fd [socket -server dummy -myaddr [info hostname] 0]
lassign [fconfigure $fd -sockname] addr host port
close $fd
### For debugging it may be useful to have a fixed port
# set port 49000
wibble listen $port
set file [file normalize $specfile]
set name [file tail $file]
if {$base eq ""} {
set dir [file dirname $file]
} else {
set dir [file normalize $base]
if {[string equal -length [string length $dir] $dir $file]} {
set name [string replace $file 0 [string length $dir]]
} else {
# The main specification is not under the specified base path
# Add a special handler to be able to serve this file
wibble handle /$name upnp root $file port $port
}
}
# Handle all (other) urls. It is the callers responsibility to make sure
# all referenced documents exist under the specified or implied base dir.
wibble handle / upnp root $dir port $port
dict set dict host $addr
dict set dict port $port
dict set dict location $name
ssdp provide $dict
return [dict get $dict uuid]
}
proc upnp::makedev {doc} {
dict set rc uuid [scan [$doc selectNodes string(ns:UDN)] uuid:%s]
dict set rc name [$doc selectNodes string(ns:deviceType)]
foreach n [$doc selectNodes ns:serviceList/ns:service] {
set ctrl [$n selectNodes string(ns:controlURL)]
set evnt [$n selectNodes string(ns:eventSubURL)]
set name [$n selectNodes string(ns:serviceType)]
dict set rc services $name [dict create control $ctrl event $evnt]
}
foreach n [$doc selectNodes ns:deviceList/ns:device] {
dict lappend rc devices [makedev $n]
}
return $rc
}
proc upnp::specfile {state} {
set fspath [dict get $state options fspath]
if {![file isdirectory $fspath] && [file exists $fspath]} {
dict set rc status 200
switch -- [file extension $fspath] {
.xml {dict set rc header content-type "" text/xml}
.png {dict set rc header content-type "" image/png}
default {dict set rc header content-type "" application/binary}
}
dict set rc header user-agent [ssdp agent]
dict set rc contentfile $fspath
return $rc
} else {
# This handler should have been able to produce the result
tailcall wibble::zone::notfound $state
}
}
proc upnp::soap {service action list1 {list2 ""}} {
dom createDocument s:Envelope doc
$doc documentElement root
$root setAttribute xmlns:s http://schemas.xmlsoap.org/soap/envelope/ \
s:encodingStyle http://schemas.xmlsoap.org/soap/encoding/
$doc createElement s:Body body
$root appendChild $body
$doc createElement u:$action act
$act setAttribute xmlns:u $service
$body appendChild $act
if {$list2 eq ""} {
set var1 {key val}
set var2 -
} else {
set var1 key
set var2 val
}
foreach $var1 $list1 $var2 $list2 {
$act appendChild [$doc createElement $key n]
$n appendChild [$doc createTextNode $val]
}
set rc {<?xml version="1.0"?>}
append rc \n [$doc asXML -indent 2]
return $rc
}
proc upnp::invoke {state} {
set cmd [string map {/ ::} [dict get $state request uri]]
dom parse [dict get $state request rawpost] doc
$doc selectNodesNamespaces {s http://schemas.xmlsoap.org/soap/envelope/}
set body [$doc selectNodes {/s:Envelope/s:Body}]
$body firstChild action
lassign [split [$action nodeName] :] ns name
set uns [$action getAttribute xmlns:$ns]
set data {}
foreach n [$action childNodes] {
dict set data [$n nodeName] [$n text]
}
if {[catch {$cmd $name $data} result]} {
dict set rc status 500
dict set rc header content-type {"" text/plain charset utf-8}
dict set rc content $result
return $rc
}
set soap [soap $uns ${name}Response $result]
dict set rc status 200
dict set rc header content-type "" text/xml
dict set rc content $soap
return $rc
}
proc upnp::revoke {} {
ssdp remove
}
namespace eval wibble {
# Turn wibble into an ensemble
namespace ensemble create -subcommands {listen handle log icc reset}
namespace eval zone {}
}
proc ::wibble::zone::upnp {state} {
# Check that the ports match
if {[dict get $state request port] != [dict get $state options port]} {
return
}
switch -- [dict get $state request method] {
GET {
# Request for a specification file
set result [::upnp::specfile $state]
}
POST {
# Service call
set result [::upnp::invoke $state]
}
SUBSCRIBE {
# Event subscription
set result ""
}
UNSUBSCRIBE {
# Cancel event subscription
set result ""
}
default {
return
}
}
if {[dict size $result]} {
sendresponse $result
}
}