#lang racket/base
(require racket/match
racket/list
racket/bool
racket/udp
racket/port
net/url
xml
"soap.rkt"
)
(provide upnp-discovery
upnp-discovery-stop
upnp-search-service-proc
upnp-search-service-proc/one-url
upnp-search-service-srvid
upnp-search-service-udnsrvid
upnp-search-service-devsrvtype
upnp-search-service-srvtype
upnp-make-service-wrapper
)
(define DEFAULT_USER_AGENT "rkt-upnp UPnP Client")
(module+ main
(define d (upnp-discovery))
(define s (upnp-search-service-srvid d "urn:upnp-org:serviceId:WANIPConn1"))
(define c (upnp-make-service-wrapper s))
(define get-external-ip (c "GetExternalIPAddress" '("NewExternalIPAddress")))
(printf "Your IP Address: ~s\n" (get-external-ip)) )
(struct rkt-upnp-discoverer
( func ))
(struct rkt-upnp-service
( func ))
(define (parse-httpu cnt)
(let* ([sp (open-input-string (bytes->string/utf-8 cnt))]
[rpc (read-line sp 'any)]
[f-loc #f]
[f-usn #f]
[f-st #f])
(match rpc
[[regexp #rx"^(?i:HTTP/[0-9.]+) +200([^0-9].*)$" [list _ _]]
(let loop ([a (read-line sp 'any)])
(unless (eof-object? a)
(match a
["" (void)]
[[regexp #rx"^([^: ]+): *(.*)$" [list _ mf mv]]
(match (list (string-upcase mf) mv)
[`["AL" ,y] (void)]
[`["ST" ,y]
(set! f-st y)
]
[`["01-NLS" ,y] (void)]
[`["LOCATION" ,y]
(match y
[[regexp "http://.+" (list _)]
(set! f-loc y)]
[[regexp "^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+:?[0-9]*$" (list _)]
(set! f-loc (format "http://~a/" y))]
[_ (void)]
)
]
[`["CACHE-CONTROL" ,y] (void)]
[`["USN" ,y]
(set! f-usn y)
]
[`["SERVER" ,y] (void)]
[`["EXT" ,y] (void)]
[`["OPT" ,y] (void)]
[`["DATE" ,y] (void)]
[`["X-USER-AGENT" ,y] (void)]
[_ (void)] )])
(loop (read-line sp 'any)) ))]
[_ (void)] )
(values f-loc f-usn f-st) )
)
(define (upnp-discovery #:wait [waitsec 10] )
(let ([us (udp-open-socket)] [hshset (make-hash)] [hshst (make-hash)] [hshusn (make-hash)]) (define thrd
(thread
(λ ()
(define (storeresponse rip rpo cnt)
(let-values ([(f-loc f-usn f-st) (parse-httpu cnt)])
(when (not (equal? #f f-loc))
(hash-set! hshset f-loc #t)
(hash-set! hshusn f-loc (cons f-usn (hash-ref hshusn f-loc '())))
(hash-set! hshst f-loc (cons f-st (hash-ref hshst f-loc '()))) ))
)
(let*([ssdpip "239.255.255.250"]
[ssdpport 1900]
[randport (+ 10000 (random 40000))] [bf (make-bytes 2048)]
[ssdpqry (string->bytes/utf-8
(string-append
"M-SEARCH * HTTP/1.1\r\n"
"HOST: " ssdpip ":" (number->string ssdpport) "\r\n"
"MAN: \"ssdp:discover\"\r\n"
"MX: 10\r\n"
"ST: ssdp:all\r\n"
"\r\n"))])
(udp-bind! us "0.0.0.0" randport) (udp-send-to us ssdpip ssdpport ssdpqry)
(let loop ()
(let-values ([(l rip rpo) (udp-receive! us bf)])
(storeresponse rip rpo (subbytes bf 0 l))
)
(loop) )))))
(sleep waitsec)
(rkt-upnp-discoverer
(λ (cmd)
(case cmd
['stop
(kill-thread thrd)
(with-handlers ([exn:fail? void])
(udp-close us))
#t]
['list
(map (λ (u0)
(let ([u (car u0)])
(list u (hash-ref hshst u '()) (hash-ref hshusn u '()))))
(hash->list hshset))
]))))
)
(define (upnp-discovery-stop dfn)
((rkt-upnp-discoverer-func dfn) 'stop))
(define (upnp-search-service-proc d filtproc #:user-agent [usragnt DEFAULT_USER_AGENT])
(let ([lst ((rkt-upnp-discoverer-func d) 'list)])
(let loop ([l lst])
(if (equal? '() l)
#f
(let ([r (upnp-search-service-proc/one-url (first (first l)) filtproc #:user-agent usragnt)])
(if (rkt-upnp-service? r)
r
(if (equal? '() (rest l))
#f
(loop (rest l))))))))
)
(define (upnp-search-service-proc/one-url urlreq filtproc #:user-agent [usragnt DEFAULT_USER_AGENT])
(with-handlers ([exn:fail? (λ (e) #f)])
(call/cc
(λ (return)
(let* ( [hdrs `(,(format "User-Agent: ~a" usragnt)
"Connection: close"
"Accept: text/html, text/xml; q=.2, */*; q=.2"
"Content-type: application/x-www-form-urlencoded")]
[inp (get-pure-port (string->url urlreq) hdrs)]
[d (xml->xexpr (document-element (read-xml inp)))]
[location urlreq] )
(define (decode-desc-dvlst a)
(let ( [devtype #f] [frdname #f]
[mfg #f] [mfgurl #f] [mfgdesc #f]
[mdlname #f] [udn #f] [prsurl #f]
[srvs '()] )
(match a
[`((xmlns ,y)) (match y ["urn:schemas-upnp-org:device-1-0" #f])]
[`(specVersion () ,specversion ...)
(for ([t specversion])
(match t
[`(major () ,maj) (void)]
[`(minor () ,min) (void)]
[_ (void)]
))
#f
]
[`(device () ,devinfo ...)
(for ([b devinfo])
(define (decode-desc-srvlst c)
(let ( [srvtype #f] [srvid #f]
[ctlurl #f] [evturl #f] [scpdurl #f] )
(match c
[`(service () ,srvinf ...)
(for ([e srvinf])
(match e
[`(serviceType () ,y)
(set! srvtype y) ]
[`(serviceId () ,y)
(set! srvid y) ]
[`(controlURL () ,y)
(set! ctlurl y) ]
[`(eventSubURL () ,y)
(set! evturl y) ]
[`(SCPDURL () ,y)
(set! scpdurl y) ]
[_ (void)]
)
)
(list srvtype srvid ctlurl evturl scpdurl)
]
[_ #f]
)
)
)
(match b
[`(deviceType () ,y)
(set! devtype y) ]
[`(friendlyName () ,y)
(set! frdname y) ]
[`(manufacturer () ,y)
(set! mfg y) ]
[`(manufacturerURL () ,y)
(set! mfgurl y) ]
[`(modelDescription () ,y)
(set! mfgdesc y) ]
[`(modelName () ,y)
(set! mdlname y) ]
[`(UDN () ,y)
(set! udn y) ]
[`(presentationURL () ,y)
(set! prsurl y) ]
[`(serviceList () ,srvlst ...)
(set! srvs (filter-not false? (map decode-desc-srvlst srvlst)))
]
[`(deviceList () ,dvlst ...)
(for-each decode-desc-dvlst dvlst)
]
[_ (void)]
)
)
(for/list ([j srvs])
(match j
[`[,srvtype ,srvid ,ctlurl ,evturl ,scpdurl]
(when (filtproc location devtype srvtype srvid udn frdname
scpdurl ctlurl evturl prsurl
mfg mfgurl mfgdesc mdlname)
(return
(rkt-upnp-service
(λ ()
(values location devtype srvtype srvid udn frdname
scpdurl ctlurl evturl prsurl
mfg mfgurl mfgdesc mdlname)))))
]))
]
[_ #f])
)
)
(for-each decode-desc-dvlst d)
))))
)
(define (upnp-search-service-srvid d svu #:user-agent [usragnt DEFAULT_USER_AGENT])
(let ([srx (regexp (string-append svu "$"))])
(upnp-search-service-proc
d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
(if (regexp-match srx srvid)
#t
#f ))
#:user-agent usragnt))
)
(define (upnp-search-service-udnsrvid d ud svu #:user-agent [usragnt DEFAULT_USER_AGENT])
(let ([srx (regexp (string-append svu "$"))])
(upnp-search-service-proc
d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
(if (and (equal? ud udn) (regexp-match srx srvid))
#t
#f ))
#:user-agent usragnt)
)
)
(define (upnp-search-service-devsrvtype d dev srv #:user-agent [usragnt DEFAULT_USER_AGENT])
(let ([drx (regexp (string-append dev "$"))]
[srx (regexp (string-append srv "$"))])
(upnp-search-service-proc
d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
(if (and (regexp-match drx devtype) (regexp-match srx srvtype))
#t
#f ))
#:user-agent usragnt))
)
(define (upnp-search-service-srvtype d srv #:user-agent [usragnt DEFAULT_USER_AGENT])
(let ([srx (regexp (string-append srv "$"))])
(upnp-search-service-proc
d (λ (location devtype srvtype srvid udn frdname scpdurl ctlurl evturl prsurl mfg mfgurl mfgdesc mdlname)
(if (regexp-match srx srvtype)
#t
#f ))
#:user-agent usragnt))
)
(define (upnp-make-service-wrapper s #:user-agent [usragnt DEFAULT_USER_AGENT])
(let-values ([(location devtype srvtype srvid udn frdname
rel*scpdurl rel*ctlurl rel*evturl prsurl
mfg mfgurl mfgdesc mdlname) ((rkt-upnp-service-func s))])
(let* ([abs*scpdurl (combine-url/relative (string->url location) rel*scpdurl)]
[abs*ctlurl (combine-url/relative (string->url location) rel*ctlurl)]
[abs*evturl (combine-url/relative (string->url location) rel*evturl)]
[hdrs `(,(format "User-Agent: ~a" usragnt)
"Connection: close"
"Accept: text/html, text/xml; q=.2, */*; q=.2"
"Content-type: application/x-www-form-urlencoded")]
[inp (get-pure-port abs*scpdurl hdrs)]
[d (xml->xexpr (document-element (read-xml inp)))]
[hshact (make-hash)]
[hshvar (make-hash)] )
(for ([a d])
(define (decode-scpd-aclst b)
(let ([e-nam #f]
[e-als #f])
(match b
[`(action () ,actinflst ...)
(for ([e actinflst])
(define (decode-scpd-aclst-act-arglist f)
(let ([g-stv #f]
[g-nam #f]
[g-dir #f])
(match f
[`(argument () ,arg ...)
(for ([g arg])
(match g
[`(relatedStateVariable () ,y) (set! g-stv y)]
[`(name () ,y) (set! g-nam y)]
[`(direction () ,y)
(set! g-dir (match y
["in" 'in]
["out" 'out]
))
]
[_ (void)]
)
)
(list g-dir g-nam g-stv)
]
[_ #f])
)
)
(match e
[`(argumentList () ,arglst ...)
(set! e-als (filter-not false? (map decode-scpd-aclst-act-arglist arglst)))
]
[`(name () ,y) (set! e-nam y)]
[_ (void)]
)
)
(hash-set! hshact e-nam e-als)
]
[_ (void)])))
(define (decode-scpd-stttbl b)
(let ([c-dvl #f]
[c-vls #f]
[c-nam #f]
[c-typ #f])
(match b
[`(stateVariable ((sendEvents ,se)) ,sttvarinf ...)
(for ([c sttvarinf])
(define (decode-scpd-stttbl-var-vallst d)
(match d
[`(allowedValue () ,y) y]
[_ #f]
)
)
(match c
[`(defaultValue () ,y)
(set! c-dvl y)
]
[`(allowedValueList () ,vallst ...)
(set! c-vls (filter-not false? (map decode-scpd-stttbl-var-vallst vallst)))
]
[`(name () ,y)
(set! c-nam y)
]
[`(dataType () ,y)
(set! c-typ (match y
["boolean" 'bool]
["string" 'string]
["ui2" 'ui2]
["ui4" 'ui4] ))
]
[_ (void)]
)
)
(hash-set! hshvar c-nam (list c-typ c-dvl c-vls))
]
[_ (void)]
)
)
)
(match a
[`((xmlns ,y)) (match y ["urn:schemas-upnp-org:service-1-0" (void)])]
[`(specVersion () ,specversion)
(for ([t specversion])
(match t
[`(major () ,maj) (void)]
[`(minor () ,min) (void)]
[_ (void)]
))
]
[`(actionList () ,aclst ...)
(for-each decode-scpd-aclst aclst)]
[`(serviceStateTable () ,stttbl ...)
(for-each decode-scpd-stttbl stttbl)]
[_ (void)]
)
)
(λ (arg0 . args)
(match (cons arg0 args)
[`[,act (,r ...) ,a ...]
(let* ([ha (hash-ref hshact act)]
[ai (map (λ (z)
(let loop ([hha ha])
(if (and (equal? 'in (first (first hha)))
(equal? z (second (first hha))))
(second (first hha))
(if (empty? hha)
(raise "Could not find In argument")
(loop (rest hha)))))
) a)]
[ar (map (λ (z)
(let loop ([hha ha])
(if (and (equal? 'out (first (first hha)))
(equal? z (second (first hha))))
(second (first hha))
(if (empty? hha)
(raise "Could not find Out argument")
(loop (rest hha)))))
) r)])
(λ args/in
(when (not (eq? (length args/in) (length ai)))
(raise "Input argument mismatch")
)
(let* ([saargs (map (λ (a b) `(,(string->symbol a) () ,b)) ai args/in)]
[soapac (format "~a#~a" srvtype act)]
[saenvb `(,(string->symbol (format "u:~a" act)) ((xmlns:u ,srvtype)) ,@saargs)]
[soapnv (soap-encode `(,saenvb) #f
"http://schemas.xmlsoap.org/soap/envelope/"
"http://schemas.xmlsoap.org/soap/encoding/")]
)
(define (handle-fault fcode fstr factor fdetl)
(printf "Fault happened: ~s~n~s~n~s~n~s~n" fcode fstr factor fdetl))
(let ([fresp
(port->string
(post-pure-port
(combine-url/relative (string->url location) rel*ctlurl) soapnv
`(,(format "SOAPAction: ~s" soapac)
"Connection: close"
"Accept: text/html, text/xml; q=.2, */*; q=.2"
"Content-Type: text/xml; charset=\"utf-8\""
,(format "User-Agent: ~a" usragnt))))])
(let-values ([(rb rh ns en) (soap-decode fresp handle-fault)])
(let ([respargs (cddr (first rb))]
[argoutset (make-hash)])
(for ([z respargs])
(match z
[`[,argo () ,argval]
(hash-set! argoutset (symbol->string argo) argval)
]
[_ (void)]
))
(apply values (map (λ (z)
(hash-ref argoutset z #f))
ar))))))))]
[`[event ,var ,proc]
(printf "c: ~s evt ~s ~s -- ~s~n" abs*evturl var proc (hash-ref hshvar var))]))))
)