394 lines
14 KiB
Racket
394 lines
14 KiB
Racket
#lang racket/base
|
|
|
|
;; Generic UPnP service inspection and SOAP invocation.
|
|
;;
|
|
;; Known service modules build small typed interfaces on top of
|
|
;; upnp-service-call. The generic call remains available for vendor-specific
|
|
;; services and actions.
|
|
|
|
(require net/http-client
|
|
net/url
|
|
racket/list
|
|
racket/port
|
|
racket/string
|
|
xml
|
|
"private/model.rkt"
|
|
"private/xml.rkt")
|
|
|
|
(provide upnp-service?
|
|
upnp-service-kind
|
|
upnp-service-type
|
|
upnp-service-id
|
|
upnp-service-kinds
|
|
upnp-device-service
|
|
upnp-service-actions
|
|
upnp-service-supports-action?
|
|
upnp-service-call
|
|
exn:fail:upnp?
|
|
exn:fail:upnp-code
|
|
exn:fail:upnp-description)
|
|
|
|
(struct exn:fail:upnp exn:fail
|
|
(code description action service)
|
|
#:transparent)
|
|
|
|
(define service-kind-table
|
|
'((av-transport
|
|
"AVTransport"
|
|
"Playback transport: URI, play, pause, stop and seek")
|
|
(rendering-control
|
|
"RenderingControl"
|
|
"Rendering properties such as volume and mute")
|
|
(connection-manager
|
|
"ConnectionManager"
|
|
"Supported transfer protocols and active connections")
|
|
(content-directory
|
|
"ContentDirectory"
|
|
"Browsing and searching media offered by a media server")
|
|
(scheduled-recording
|
|
"ScheduledRecording"
|
|
"Scheduling and managing recordings")
|
|
(print-basic
|
|
"PrintBasic"
|
|
"Submitting and managing basic print jobs")
|
|
(print-enhanced-layout
|
|
"PrintEnhancedLayout"
|
|
"Submitting print jobs with enhanced layout options")
|
|
(scan
|
|
"Scan"
|
|
"Starting scan jobs and retrieving scanned images")
|
|
(feeder
|
|
"Feeder"
|
|
"Controlling document feeders for scanners and similar devices")
|
|
(external-activity
|
|
"ExternalActivity"
|
|
"Registering for front-panel activity on scanner devices")
|
|
(wan-ip-connection
|
|
"WANIPConnection"
|
|
"Internet gateway IP connection and port mappings")
|
|
(wan-ppp-connection
|
|
"WANPPPConnection"
|
|
"Internet gateway PPP connection and port mappings")
|
|
(layer-3-forwarding
|
|
"Layer3Forwarding"
|
|
"Internet gateway default connection selection")
|
|
(switch-power
|
|
"SwitchPower"
|
|
"Binary power switching")
|
|
(dimming
|
|
"Dimming"
|
|
"Light dimming control")))
|
|
|
|
(define action-cache (make-weak-hasheq))
|
|
(define action-cache-lock (make-semaphore 1))
|
|
|
|
(define (upnp-service-kinds)
|
|
(for/list ([entry (in-list service-kind-table)])
|
|
(cons (car entry) (caddr entry))))
|
|
|
|
(define (upnp-type-name type category)
|
|
(and type
|
|
(let ([match
|
|
(regexp-match
|
|
(pregexp
|
|
(format "(?i:^urn:[^:]+:~a:([^:]+):[0-9]+$)" category))
|
|
type)])
|
|
(and match (cadr match)))))
|
|
|
|
(define (upnp-type-version type category)
|
|
(if type
|
|
(let ([match
|
|
(regexp-match
|
|
(pregexp
|
|
(format "(?i:^urn:[^:]+:~a:[^:]+:([0-9]+)$)" category))
|
|
type)])
|
|
(if match
|
|
(string->number (cadr match))
|
|
0))
|
|
0))
|
|
|
|
(define (service-kind-by-name name)
|
|
(let ([entry
|
|
(and name
|
|
(findf
|
|
(lambda (candidate)
|
|
(string-ci=? (cadr candidate) name))
|
|
service-kind-table))])
|
|
(if entry (car entry) 'unknown)))
|
|
|
|
(define (upnp-service-kind service)
|
|
(unless (upnp-service? service)
|
|
(raise-argument-error 'upnp-service-kind "upnp-service?" service))
|
|
(service-kind-by-name
|
|
(upnp-type-name (upnp-service-service-type service) "service")))
|
|
|
|
(define (upnp-service-type service)
|
|
(unless (upnp-service? service)
|
|
(raise-argument-error 'upnp-service-type "upnp-service?" service))
|
|
(upnp-service-service-type service))
|
|
|
|
(define (upnp-service-id service)
|
|
(unless (upnp-service? service)
|
|
(raise-argument-error 'upnp-service-id "upnp-service?" service))
|
|
(upnp-service-service-id service))
|
|
|
|
;; Return the highest advertised version of a known service kind, or #f when
|
|
;; the device does not provide that service.
|
|
(define (upnp-device-service device kind)
|
|
(unless (upnp-device? device)
|
|
(raise-argument-error 'upnp-device-service "upnp-device?" device))
|
|
(unless (symbol? kind)
|
|
(raise-argument-error 'upnp-device-service "symbol?" kind))
|
|
(let ([services
|
|
(filter
|
|
(lambda (service)
|
|
(eq? (upnp-service-kind service) kind))
|
|
(upnp-device-services device))])
|
|
(and (pair? services)
|
|
(argmax
|
|
(lambda (service)
|
|
(upnp-type-version (upnp-service-service-type service) "service"))
|
|
services))))
|
|
|
|
(define (read-xml-url location)
|
|
(call/input-url
|
|
(string->url location)
|
|
(lambda (url)
|
|
(get-pure-port url '() #:redirections 3))
|
|
(lambda (in)
|
|
(xml->xexpr (document-element (read-xml in))))))
|
|
|
|
(define (read-service-actions service)
|
|
(let ([location (upnp-service-scpd-url service)])
|
|
(unless location
|
|
(raise-arguments-error 'upnp-service-actions
|
|
"service has no SCPDURL"
|
|
"service" service))
|
|
(let* ([description (read-xml-url location)]
|
|
[action-list (xexpr-find-descendant description "actionList" #f)])
|
|
(if action-list
|
|
(filter-map
|
|
(lambda (action)
|
|
(xexpr-child-text action "name" #f))
|
|
(xexpr-child-elements action-list "action"))
|
|
'()))))
|
|
|
|
;; Read and cache the action names advertised by the service's SCPD document.
|
|
(define (upnp-service-actions service)
|
|
(unless (upnp-service? service)
|
|
(raise-argument-error 'upnp-service-actions "upnp-service?" service))
|
|
(call-with-semaphore
|
|
action-cache-lock
|
|
(lambda ()
|
|
(hash-ref action-cache
|
|
service
|
|
(lambda ()
|
|
(let ([actions (read-service-actions service)])
|
|
(hash-set! action-cache service actions)
|
|
actions))))))
|
|
|
|
(define (upnp-service-supports-action? service action)
|
|
(unless (upnp-service? service)
|
|
(raise-argument-error 'upnp-service-supports-action?
|
|
"upnp-service?"
|
|
service))
|
|
(unless (or (string? action) (symbol? action))
|
|
(raise-argument-error 'upnp-service-supports-action?
|
|
"(or/c string? symbol?)"
|
|
action))
|
|
(let ([name (if (symbol? action) (symbol->string action) action)])
|
|
(ormap (lambda (candidate) (string-ci=? candidate name))
|
|
(upnp-service-actions service))))
|
|
|
|
(define (argument-name value)
|
|
(cond
|
|
[(string? value) value]
|
|
[(symbol? value) (symbol->string value)]
|
|
[else
|
|
(raise-argument-error 'upnp-service-call
|
|
"argument name as string? or symbol?"
|
|
value)]))
|
|
|
|
(define (argument-value value)
|
|
(cond
|
|
[(string? value) value]
|
|
[(bytes? value) (bytes->string/utf-8 value)]
|
|
[(boolean? value) (if value "1" "0")]
|
|
[(symbol? value) (symbol->string value)]
|
|
[else (format "~a" value)]))
|
|
|
|
(define (soap-envelope service-type action arguments)
|
|
(let* ([action-name (if (symbol? action) (symbol->string action) action)]
|
|
[action-tag (string->symbol (string-append "u:" action-name))]
|
|
[argument-elements
|
|
(for/list ([argument (in-list arguments)])
|
|
(unless (pair? argument)
|
|
(raise-argument-error 'upnp-service-call
|
|
"(listof pair?)"
|
|
arguments))
|
|
(list (string->symbol (argument-name (car argument)))
|
|
'()
|
|
(argument-value (cdr argument))))]
|
|
[document
|
|
`(s:Envelope
|
|
((xmlns:s "http://schemas.xmlsoap.org/soap/envelope/")
|
|
(s:encodingStyle "http://schemas.xmlsoap.org/soap/encoding/"))
|
|
(s:Body
|
|
()
|
|
(,action-tag
|
|
((xmlns:u ,service-type))
|
|
,@argument-elements)))])
|
|
(string->bytes/utf-8
|
|
(string-append "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
|
|
(xexpr->string document)))))
|
|
|
|
(define (url-request-target value)
|
|
(let* ([relative
|
|
(struct-copy url value
|
|
[scheme #f]
|
|
[user #f]
|
|
[host #f]
|
|
[port #f]
|
|
[fragment #f])]
|
|
[target (url->string relative)])
|
|
(if (string=? target "") "/" target)))
|
|
|
|
(define (http-status-code status)
|
|
(let ([match
|
|
(regexp-match #px"^HTTP/[0-9.]+[ ]+([0-9]{3})(?:[ ]|$)"
|
|
(bytes->string/latin-1 status))])
|
|
(and match (string->number (cadr match)))))
|
|
|
|
(define (read-response-body in)
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (port->bytes in))
|
|
(lambda () (close-input-port in))))
|
|
|
|
(define (send-soap-request service action arguments)
|
|
(let* ([control-url (upnp-service-control-url service)]
|
|
[service-type (upnp-service-service-type service)]
|
|
[action-name (if (symbol? action) (symbol->string action) action)])
|
|
(unless control-url
|
|
(raise-arguments-error 'upnp-service-call
|
|
"service has no controlURL"
|
|
"service" service))
|
|
(unless service-type
|
|
(raise-arguments-error 'upnp-service-call
|
|
"service has no serviceType"
|
|
"service" service))
|
|
(let* ([url-value (string->url control-url)]
|
|
[scheme (or (url-scheme url-value) "http")]
|
|
[ssl? (string-ci=? scheme "https")]
|
|
[host (url-host url-value)]
|
|
[port (or (url-port url-value) (if ssl? 443 80))]
|
|
[body (soap-envelope service-type action-name arguments)]
|
|
[headers
|
|
(list "Content-Type: text/xml; charset=\"utf-8\""
|
|
(format "SOAPACTION: \"~a#~a\"" service-type action-name)
|
|
"Connection: close")])
|
|
(unless host
|
|
(raise-arguments-error 'upnp-service-call
|
|
"controlURL has no host"
|
|
"controlURL" control-url))
|
|
(let-values ([(status response-headers in)
|
|
(http-sendrecv host
|
|
(url-request-target url-value)
|
|
#:ssl? ssl?
|
|
#:port port
|
|
#:method #"POST"
|
|
#:headers headers
|
|
#:data body)])
|
|
(values (http-status-code status)
|
|
response-headers
|
|
(read-response-body in))))))
|
|
|
|
(define (bytes->xexpr body)
|
|
(call-with-input-bytes
|
|
body
|
|
(lambda (in)
|
|
(xml->xexpr (document-element (read-xml in))))))
|
|
|
|
(define (soap-fault-values response)
|
|
(let* ([fault (xexpr-find-descendant response "Fault" #f)]
|
|
[code-element (and fault (xexpr-find-descendant fault "errorCode" #f))]
|
|
[description-element
|
|
(and fault (xexpr-find-descendant fault "errorDescription" #f))])
|
|
(values (and code-element (xexpr-text code-element #f))
|
|
(and description-element (xexpr-text description-element #f)))))
|
|
|
|
(define (raise-upnp-error service action code description)
|
|
(raise
|
|
(exn:fail:upnp
|
|
(format "UPnP action ~a failed~a: ~a"
|
|
action
|
|
(if code (format " with error ~a" code) "")
|
|
(or description "unknown error"))
|
|
(current-continuation-marks)
|
|
code
|
|
description
|
|
action
|
|
service)))
|
|
|
|
(define (element-local-name value)
|
|
(let ([parts (string-split (symbol->string (car value)) ":")])
|
|
(last parts)))
|
|
|
|
(define (response-result response service action)
|
|
(let* ([body (xexpr-find-descendant response "Body" #f)]
|
|
[elements (if body
|
|
(filter xexpr-element? (xexpr-children body))
|
|
'())]
|
|
[result-element (and (pair? elements) (car elements))])
|
|
(cond
|
|
[(not result-element) (hash)]
|
|
[(string=? (xexpr-local-name (car result-element)) "fault")
|
|
(let-values ([(code description) (soap-fault-values response)])
|
|
(raise-upnp-error service action code description))]
|
|
[else
|
|
(for/fold ([result (hash)])
|
|
([value (in-list (xexpr-children result-element))]
|
|
#:when (xexpr-element? value))
|
|
(hash-set result
|
|
(element-local-name value)
|
|
(or (xexpr-text value #f) "")))])))
|
|
|
|
(define (body-preview body)
|
|
(let* ([text (string-trim (bytes->string/utf-8 body #\uFFFD))]
|
|
[length (string-length text)])
|
|
(if (> length 300)
|
|
(string-append (substring text 0 300) "...")
|
|
text)))
|
|
|
|
;; Invoke a SOAP action. arguments is an association list whose keys are the
|
|
;; exact UPnP argument names. The result is an immutable hash with the exact
|
|
;; output argument names as string keys.
|
|
(define (upnp-service-call service action [arguments '()])
|
|
(unless (upnp-service? service)
|
|
(raise-argument-error 'upnp-service-call "upnp-service?" service))
|
|
(unless (or (string? action) (symbol? action))
|
|
(raise-argument-error 'upnp-service-call
|
|
"(or/c string? symbol?)"
|
|
action))
|
|
(unless (list? arguments)
|
|
(raise-argument-error 'upnp-service-call "list?" arguments))
|
|
(let ([action-name (if (symbol? action) (symbol->string action) action)])
|
|
(let-values ([(status headers body)
|
|
(send-soap-request service action-name arguments)])
|
|
(cond
|
|
[(and status (<= 200 status 299))
|
|
(if (zero? (bytes-length body))
|
|
(hash)
|
|
(response-result (bytes->xexpr body) service action-name))]
|
|
[(positive? (bytes-length body))
|
|
(let-values ([(code description)
|
|
(with-handlers
|
|
([exn:fail? (lambda (_) (values #f #f))])
|
|
(soap-fault-values (bytes->xexpr body)))])
|
|
(raise-upnp-error service
|
|
action-name
|
|
(or code status)
|
|
(or description (body-preview body))))]
|
|
[else
|
|
(raise-upnp-error service action-name status "empty HTTP response")]))))
|