Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
586 lines (554 sloc) 23.4 KB
#lang racket/base
#|
UPnP Client Library for Racket
upnp-client.rkt
This file is part of rkt-upnp.
This file is subject to the terms of a MIT-style license, please
refer to LICENSE.txt for details.
How it works:
(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")))
(define add-port-mapping (c "AddPortMapping" '() "NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration"))
And then use (get-external-ip) to get the external ip, or use (add-port-mapping ...) with the parameters
|#
(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")
#|
Submodule to try out the UPnP client library.
|#
(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)) )
#|
Structs for this library
|#
(struct rkt-upnp-discoverer
( func ))
(struct rkt-upnp-service
( func ))
#|
parse-httpu
Parse UDP-HTTP into 3 values:
* Service URL
* Unique Service Name (USN)
* Search Target (ST)
|#
(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) )
)
#|
upnp-discovery
Perform UPnP Discovery
|#
(define (upnp-discovery #:wait [waitsec 10] )
(let ([us (udp-open-socket)] ; UDP port
[hshset (make-hash)] ; key: url-location value: #t
[hshst (make-hash)] ; key: url-location value: list of Search Targets (ST)
[hshusn (make-hash)]) ; key: url-location value: list of Unique Service Names (USN)
(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))] ; TODO: Make random port
[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) ; make random port number
(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))
#|
upnp-search-service-proc
Search incoming service announcements using proc as predicate.
|#
; (define s (upnp-search-service-srvtype d "service:WANIPConnection:1"))
; TODO: Change d0 to handle list of discovered devices
(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))))))))
)
#|
upnp-search-service-proc/one-url
Search service announcements available from one service listing URL.
|#
(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) ; e.g. "urn:schemas-upnp-org:service:WANIPConnection:1"
]
[`(serviceId () ,y)
(set! srvid y) ; e.g. "urn:upnp-org:serviceId:WANIPConnection"
]
[`(controlURL () ,y)
(set! ctlurl y) ; e.g. "/upnp/control1"
]
[`(eventSubURL () ,y)
(set! evturl y) ; e.g. "/WANIPConnection"
]
[`(SCPDURL () ,y)
(set! scpdurl y) ; e.g. "http://192.168.0.1:80/serv3.xml"
]
[_ (void)]
)
)
(list srvtype srvid ctlurl evturl scpdurl)
]
[_ #f]
)
)
)
(match b
[`(deviceType () ,y)
(set! devtype y) ; e.g. "urn:schemas-upnp-org:device:WANConnectionDevice:1"
]
[`(friendlyName () ,y)
(set! frdname y) ; e.g. "WAN Connection Device"
]
[`(manufacturer () ,y)
(set! mfg y) ; e.g. "D-Link"
]
[`(manufacturerURL () ,y)
(set! mfgurl y) ; e.g. "http://www.dlink.com"
]
[`(modelDescription () ,y)
(set! mfgdesc y) ; e.g. "Residential Gateway"
]
[`(modelName () ,y)
(set! mdlname y) ; e.g. "Residential Gateway Device"
]
[`(UDN () ,y)
(set! udn y) ; e.g. "uuid:000F3D19-AF81-0000-0000-0002C0A80001"
]
[`(presentationURL () ,y)
(set! prsurl y) ; e.g. "http://192.168.0.1:80/"
]
[`(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])
)
)
;(printf "~s~n~n" d)
(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)
;(printf "~s ?= ~s -> ~s~n" srx srvid (regexp-match srx srvid))
(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))
)
#|
upnp-make-service-wrapper
Create a new procedure-creating procedure from a specific service
|#
(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")]
;[_tmp (let () (printf "~s" (url->string abs*scpdurl)))]
[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)
; TODO: Generate lambdas of UPnP actions:
; (define scpd (decode-scpd ... ))
(match (cons arg0 args)
; (scpd "AddPortMapping" '(OutArguments ...) InArguments ...)
[`[,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))))])
;(printf "Response: ~s\n" fresp)
(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))))))))]
; (scpd 'event "ConnectionType" (λ (v) (void)))
[`[event ,var ,proc]
(printf "c: ~s evt ~s ~s -- ~s~n" abs*evturl var proc (hash-ref hshvar var))]))))
)
#|
; Some example possible commands
((c "SetConnectionType" '() "NewConnectionType") "")
((c "GetConnectionTypeInfo" '("NewConnectionType" "NewPossibleConnectionTypes")))
((c "ForceTermination" '()))
((c "RequestConnection" '()))
((c "GetStatusInfo" '("NewConnectionStatus" "NewLastConnectionError" "NewUptime")))
((c "GetNATRSIPStatus" '("NewRSIPAvailable" "NewNATEnabled")))
((c "GetGenericPortMappingEntry" '("NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration") "NewPortMappingIndex") "")
((c "GetSpecificPortMappingEntry" '("NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration") "NewRemoteHost" "NewExternalPort" "NewProtocol") "NewRemoteHost" "NewExternalPort" "NewProtocol")
((c "AddPortMapping" '() "NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration") "NewRemoteHost" "NewExternalPort" "NewProtocol" "NewInternalPort" "NewInternalClient" "NewEnabled" "NewPortMappingDescription" "NewLeaseDuration")
((c "DeletePortMapping" '() "NewRemoteHost" "NewExternalPort" "NewProtocol") "NewRemoteHost" "NewExternalPort" "NewProtocol")
((c "GetExternalIPAddress" '("NewExternalIPAddress")))
; TODO: Maybe later implement events
(c 'event "ConnectionType" (λ(v) (void)))
(c 'event "PossibleConnectionTypes" (λ(v) (void)))
(c 'event "ConnectionStatus" (λ(v) (void)))
(c 'event "Uptime" (λ(v) (void)))
(c 'event "LastConnectionError" (λ(v) (void)))
(c 'event "RSIPAvailable" (λ(v) (void)))
(c 'event "NATEnabled" (λ(v) (void)))
(c 'event "ExternalIPAddress" (λ(v) (void)))
(c 'event "PortMappingNumberOfEntries" (λ(v) (void)))
(c 'event "PortMappingEnabled" (λ(v) (void)))
(c 'event "PortMappingLeaseDuration" (λ(v) (void)))
(c 'event "RemoteHost" (λ(v) (void)))
(c 'event "ExternalPort" (λ(v) (void)))
(c 'event "InternalPort" (λ(v) (void)))
(c 'event "PortMappingProtocol" (λ(v) (void)))
(c 'event "InternalClient" (λ(v) (void)))
(c 'event "PortMappingDescription" (λ(v) (void)))
|#
; Services:
; "urn:upnp-org:serviceId:WANIPConnection"
; "urn:upnp-org:serviceId:WANIPConn1"
; "urn:upnp-org:serviceId:WANPPPConn1"
; "urn:upnp-org:serviceId:WANCommonIFC1"
; "urn:upnp-org:serviceId:Layer3Forwarding:11"