Initial import
This commit is contained in:
+393
@@ -0,0 +1,393 @@
|
||||
#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")]))))
|
||||
Reference in New Issue
Block a user