Initial import
This commit is contained in:
@@ -15,3 +15,7 @@ compiled/
|
||||
# Dependency tracking files
|
||||
*.dep
|
||||
|
||||
*.bak
|
||||
/scribblings/*.css
|
||||
/scribblings/*.js
|
||||
/scribblings/*.html
|
||||
|
||||
@@ -1,3 +1,165 @@
|
||||
# racket-dlna
|
||||
# Racket UPnP module
|
||||
|
||||
DLNA implementation for racket
|
||||
This directory contains a small, layered UPnP control-point implementation.
|
||||
The public interfaces deliberately hide SSDP, XML, SCPD and SOAP details unless
|
||||
the generic service escape hatch is used.
|
||||
|
||||
## Module layout
|
||||
|
||||
```text
|
||||
upnp/main.rkt generic public interface
|
||||
upnp/media-renderer.rkt high-level renderer operations
|
||||
upnp/media-server.rkt high-level MediaServer browser
|
||||
upnp/services/av-transport.rkt playback transport
|
||||
upnp/services/rendering-control.rkt volume and mute
|
||||
upnp/services/connection-manager.rkt protocol and connection information
|
||||
upnp/services/content-directory.rkt media-server browse and search
|
||||
upnp/ssdp.rkt low-level SSDP discovery
|
||||
upnp/device.rkt device-description parsing
|
||||
upnp/service.rkt SCPD inspection and SOAP calls
|
||||
```
|
||||
|
||||
The collection can be required as `upnp` when the package root is on Racket's
|
||||
collection path.
|
||||
|
||||
## Generic device discovery
|
||||
|
||||
```racket
|
||||
#lang racket/base
|
||||
|
||||
(require upnp)
|
||||
|
||||
(define devices
|
||||
(query-upnp-devices '(media-renderer scanner)
|
||||
#:interface "10.7.3.118"
|
||||
#:dns? #t))
|
||||
|
||||
(for ([device (in-list devices)])
|
||||
(printf "~a: ~a\n"
|
||||
(upnp-device-kind device)
|
||||
(upnp-device-name device)))
|
||||
```
|
||||
|
||||
Known friendly device kinds are returned by:
|
||||
|
||||
```racket
|
||||
(upnp-device-kinds)
|
||||
```
|
||||
|
||||
Without a kind, all described UPnP devices are returned:
|
||||
|
||||
```racket
|
||||
(query-upnp-devices)
|
||||
```
|
||||
|
||||
Unknown vendor-specific device types are retained and classified as
|
||||
`'unknown`; their original URN remains available through `upnp-device-type`.
|
||||
|
||||
## Service inspection
|
||||
|
||||
```racket
|
||||
(define renderer (car (query-upnp-devices 'media-renderer)))
|
||||
|
||||
(for ([service (in-list (upnp-device-services renderer))])
|
||||
(printf "~a: ~a\n"
|
||||
(upnp-service-kind service)
|
||||
(upnp-service-actions service)))
|
||||
```
|
||||
|
||||
`upnp-service-call` is the generic escape hatch for standard services that do
|
||||
not yet have a typed module and for manufacturer-specific services.
|
||||
|
||||
## One module per known service
|
||||
|
||||
```racket
|
||||
(require upnp/services/av-transport
|
||||
upnp/services/rendering-control)
|
||||
|
||||
(define transport (device-av-transport renderer))
|
||||
(define rendering (device-rendering-control renderer))
|
||||
|
||||
(av-transport-set-uri!
|
||||
transport
|
||||
"http://10.7.3.118:8080/media/test.flac")
|
||||
(av-transport-play! transport)
|
||||
(rendering-control-set-volume! rendering 30)
|
||||
```
|
||||
|
||||
The currently implemented typed service modules are:
|
||||
|
||||
- `upnp/services/av-transport`
|
||||
- `upnp/services/rendering-control`
|
||||
- `upnp/services/connection-manager`
|
||||
- `upnp/services/content-directory`
|
||||
|
||||
A typed service value is still the generic `upnp-service` value. No extra
|
||||
wrapper objects or public constructors are needed.
|
||||
|
||||
|
||||
## Media-server browser
|
||||
|
||||
The higher media-server layer parses ContentDirectory DIDL-Lite into ordinary
|
||||
containers, items and resources:
|
||||
|
||||
```racket
|
||||
(require upnp/media-server)
|
||||
|
||||
(define synology
|
||||
(car (query-media-servers #:interface "10.7.3.118")))
|
||||
|
||||
(define root (media-server-root synology))
|
||||
(define music
|
||||
(findf (lambda (entry)
|
||||
(and (media-container? entry)
|
||||
(string=? (media-entry-title entry) "Muziek")))
|
||||
root))
|
||||
|
||||
(define entries (media-container-children synology music))
|
||||
|
||||
(for ([entry (in-list entries)])
|
||||
(printf "~a: ~a\n"
|
||||
(if (media-container? entry) 'container 'item)
|
||||
(media-entry-title entry)))
|
||||
```
|
||||
|
||||
A media item can advertise several resources. Their URLs are available with
|
||||
`media-item-resources` and `media-resource-uri`. Containers are followed one
|
||||
level at a time; the published hierarchy can be a logical artist/album/genre
|
||||
view rather than the physical filesystem.
|
||||
|
||||
## Media-renderer convenience layer
|
||||
|
||||
Normal playback code need not mention AVTransport or SOAP:
|
||||
|
||||
```racket
|
||||
(require upnp
|
||||
upnp/media-renderer)
|
||||
|
||||
(define denon
|
||||
(car (query-media-renderers
|
||||
#:interface "10.7.3.118"
|
||||
#:dns? #t)))
|
||||
|
||||
(media-renderer-play-uri!
|
||||
denon
|
||||
"http://10.7.3.118:8080/media/test.flac")
|
||||
|
||||
(media-renderer-seek! denon 120)
|
||||
(media-renderer-set-volume! denon 30)
|
||||
```
|
||||
|
||||
`query-media-renderers` returns all UPnP MediaRenderers by default. Add
|
||||
`#:dlna-only? #t` to retain only devices advertising `X_DLNADOC`.
|
||||
|
||||
A later HTTP media-serving module can implement `play-file!` by publishing a
|
||||
local file through Racket's web-server framework and passing the resulting URL
|
||||
to `media-renderer-play-uri!`.
|
||||
|
||||
## Documentation and tests
|
||||
|
||||
The Scribble manual is in `upnp/scribblings/upnp.scrbl`.
|
||||
|
||||
The test file `upnp/tests/upnp-test.rkt` uses a local mock HTTP/SOAP server and
|
||||
covers service discovery from SCPD, SOAP calls, SOAP faults, AVTransport,
|
||||
RenderingControl, ConnectionManager, ContentDirectory and DIDL-Lite media
|
||||
server browsing.
|
||||
|
||||
+158
@@ -0,0 +1,158 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Retrieval and parsing of UPnP device-description documents.
|
||||
|
||||
(require net/dns
|
||||
net/url
|
||||
racket/list
|
||||
racket/string
|
||||
xml
|
||||
"private/model.rkt"
|
||||
"private/xml.rkt"
|
||||
"ssdp.rkt")
|
||||
|
||||
(provide upnp-device?
|
||||
upnp-device-udn
|
||||
upnp-device-type
|
||||
upnp-device-friendly-name
|
||||
upnp-device-manufacturer
|
||||
upnp-device-model-name
|
||||
upnp-device-model-number
|
||||
upnp-device-serial-number
|
||||
upnp-device-location
|
||||
upnp-device-address
|
||||
upnp-device-dns-name
|
||||
upnp-device-services
|
||||
upnp-device-embedded-devices
|
||||
upnp-device-property
|
||||
upnp-device-tree
|
||||
upnp-describe)
|
||||
|
||||
(define (upnp-device-type device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-type "upnp-device?" device))
|
||||
(upnp-device-device-type device))
|
||||
|
||||
(define (absolute-url base-url value)
|
||||
(and value
|
||||
(url->string (combine-url/relative base-url value))))
|
||||
|
||||
(define (resolve-dns-name address)
|
||||
(let ([nameserver (dns-find-nameserver)])
|
||||
(and nameserver
|
||||
(with-handlers ([exn:fail? (lambda (_) #f)])
|
||||
(dns-get-name nameserver address)))))
|
||||
|
||||
(define (parse-service value base-url)
|
||||
(upnp-service
|
||||
(xexpr-child-text value "serviceType")
|
||||
(xexpr-child-text value "serviceId")
|
||||
(absolute-url base-url (xexpr-child-text value "SCPDURL"))
|
||||
(absolute-url base-url (xexpr-child-text value "controlURL"))
|
||||
(absolute-url base-url (xexpr-child-text value "eventSubURL"))))
|
||||
|
||||
(define (device-properties value)
|
||||
(for/fold ([properties (hash)])
|
||||
([child (in-list (xexpr-children value))]
|
||||
#:when (xexpr-element? child))
|
||||
(let* ([name (xexpr-local-name (car child))]
|
||||
[text (xexpr-text child #f)])
|
||||
(if (and text
|
||||
(not (member name '("servicelist" "devicelist" "iconlist"))))
|
||||
(hash-set properties name text)
|
||||
properties))))
|
||||
|
||||
(define (parse-device value base-url location address dns-name)
|
||||
(let* ([service-list (xexpr-child-element value "serviceList" #f)]
|
||||
[device-list (xexpr-child-element value "deviceList" #f)]
|
||||
[services
|
||||
(if service-list
|
||||
(for/list ([service (in-list (xexpr-child-elements service-list "service"))])
|
||||
(parse-service service base-url))
|
||||
'())]
|
||||
[embedded-devices
|
||||
(if device-list
|
||||
(for/list ([device (in-list (xexpr-child-elements device-list "device"))])
|
||||
(parse-device device base-url location address dns-name))
|
||||
'())])
|
||||
(upnp-device
|
||||
(xexpr-child-text value "UDN")
|
||||
(xexpr-child-text value "deviceType")
|
||||
(xexpr-child-text value "friendlyName")
|
||||
(xexpr-child-text value "manufacturer")
|
||||
(xexpr-child-text value "modelName")
|
||||
(xexpr-child-text value "modelNumber")
|
||||
(xexpr-child-text value "serialNumber")
|
||||
location
|
||||
address
|
||||
dns-name
|
||||
services
|
||||
embedded-devices
|
||||
(device-properties value))))
|
||||
|
||||
(define (read-description 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 (description-base-url description location)
|
||||
(let* ([location-url (string->url location)]
|
||||
[url-base (xexpr-child-text description "URLBase" #f)])
|
||||
(if url-base
|
||||
(combine-url/relative location-url url-base)
|
||||
location-url)))
|
||||
|
||||
;; Return a property from the immediate device element. Property names are
|
||||
;; matched case-insensitively and without an XML namespace prefix.
|
||||
(define (upnp-device-property device name [default #f])
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-property "upnp-device?" device))
|
||||
(unless (or (string? name) (symbol? name))
|
||||
(raise-argument-error 'upnp-device-property "(or/c string? symbol?)" name))
|
||||
(hash-ref (upnp-device-properties device)
|
||||
(string-downcase (if (symbol? name) (symbol->string name) name))
|
||||
default))
|
||||
|
||||
;; Flatten a root device and all embedded devices in document order.
|
||||
(define (upnp-device-tree device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-tree "upnp-device?" device))
|
||||
(cons device
|
||||
(append-map upnp-device-tree
|
||||
(upnp-device-embedded-devices device))))
|
||||
|
||||
;; Download and parse the device description referenced by a group of SSDP
|
||||
;; responses. All responses must point to the same LOCATION.
|
||||
(define (upnp-describe responses #:dns? [dns? #f])
|
||||
(unless (and (list? responses)
|
||||
(pair? responses)
|
||||
(andmap ssdp-response? responses))
|
||||
(raise-argument-error 'upnp-describe
|
||||
"non-empty-list-of-ssdp-response?"
|
||||
responses))
|
||||
(let* ([first-response (car responses)]
|
||||
[location (ssdp-response-location first-response #f)]
|
||||
[address (ssdp-response-address first-response)])
|
||||
(unless location
|
||||
(raise-arguments-error 'upnp-describe
|
||||
"SSDP response has no LOCATION header"
|
||||
"response" first-response))
|
||||
(unless (andmap
|
||||
(lambda (response)
|
||||
(equal? (ssdp-response-location response #f) location))
|
||||
responses)
|
||||
(raise-arguments-error 'upnp-describe
|
||||
"all SSDP responses must have the same LOCATION"
|
||||
"location" location))
|
||||
(let* ([description (read-description location)]
|
||||
[base-url (description-base-url description location)]
|
||||
[device (xexpr-child-element description "device" #f)]
|
||||
[dns-name (and dns? (resolve-dns-name address))])
|
||||
(unless device
|
||||
(raise-arguments-error 'upnp-describe
|
||||
"UPnP description contains no device element"
|
||||
"location" location))
|
||||
(parse-device device base-url location address dns-name))))
|
||||
@@ -0,0 +1,18 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "../main.rkt"
|
||||
"../media-renderer.rkt")
|
||||
|
||||
(define renderers
|
||||
(query-media-renderers
|
||||
#:interface "10.7.3.118"
|
||||
#:dns? #t))
|
||||
|
||||
(for ([renderer (in-list renderers)])
|
||||
(printf "~a\n" (upnp-device-name renderer))
|
||||
(printf " kind: ~a\n" (upnp-device-kind renderer))
|
||||
(printf " address: ~a\n" (upnp-device-address renderer))
|
||||
(printf " dns-name: ~a\n" (or (upnp-device-dns-name renderer) ""))
|
||||
(printf " model: ~a\n" (or (upnp-device-model renderer) ""))
|
||||
(printf " services: ~a\n\n"
|
||||
(map upnp-service-kind (upnp-device-services renderer))))
|
||||
@@ -0,0 +1,36 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
"upnp/main.rkt"
|
||||
"upnp/media-server.rkt")
|
||||
|
||||
(define servers
|
||||
(query-media-servers
|
||||
#:interface "10.7.3.118"
|
||||
#:dns? #t))
|
||||
|
||||
(for ([server (in-list servers)])
|
||||
(printf "~a (~a)\n"
|
||||
(upnp-device-name server)
|
||||
(upnp-device-address server)))
|
||||
|
||||
(when (pair? servers)
|
||||
(let* ([server (car servers)]
|
||||
[root (media-server-root server)]
|
||||
[music
|
||||
(findf
|
||||
(lambda (entry)
|
||||
(and (media-container? entry)
|
||||
(string=? (media-entry-title entry) "Muziek")))
|
||||
root)])
|
||||
(for ([entry (in-list root)])
|
||||
(printf "~a ~a ~a\n"
|
||||
(if (media-container? entry) "map " "item")
|
||||
(or (media-entry-id entry) "")
|
||||
(media-entry-title entry)))
|
||||
(when music
|
||||
(displayln "\nMuziek:")
|
||||
(for ([entry (in-list (media-container-children server music))])
|
||||
(printf "~a ~a\n"
|
||||
(if (media-container? entry) "map " "item")
|
||||
(media-entry-title entry))))))
|
||||
@@ -0,0 +1,6 @@
|
||||
#lang info
|
||||
|
||||
(define deps '("base" "net-lib" "xml-lib"))
|
||||
(define build-deps '("racket-doc" "scribble-lib"))
|
||||
(define scribblings
|
||||
'(("scribblings/racket-upnp.scrbl" (multi-page))))
|
||||
@@ -0,0 +1,23 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Main public interface for racket-upnp.
|
||||
;;
|
||||
;; This module provides:
|
||||
;; - generic UPnP device discovery and service inspection;
|
||||
;; - the high-level media-renderer interface;
|
||||
;; - the high-level media-server browser interface.
|
||||
;;
|
||||
;; Service-specific interfaces remain available through:
|
||||
;; racket-upnp/services/<service>
|
||||
|
||||
(require "query.rkt"
|
||||
"service.rkt"
|
||||
"media-renderer.rkt"
|
||||
"media-server.rkt")
|
||||
|
||||
(provide
|
||||
(all-from-out
|
||||
"query.rkt"
|
||||
"service.rkt"
|
||||
"media-renderer.rkt"
|
||||
"media-server.rkt"))
|
||||
@@ -0,0 +1,195 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Device-oriented convenience interface for UPnP/DLNA media renderers.
|
||||
;;
|
||||
;; This layer hides AVTransport and RenderingControl for common playback and
|
||||
;; volume operations. The underlying device value remains an upnp-device, so
|
||||
;; generic service inspection is still possible.
|
||||
|
||||
(require racket/list
|
||||
racket/string
|
||||
"device.rkt"
|
||||
"query.rkt"
|
||||
"service.rkt"
|
||||
"services/av-transport.rkt"
|
||||
"services/rendering-control.rkt")
|
||||
|
||||
(provide query-media-renderers
|
||||
media-renderer?
|
||||
media-renderer-name
|
||||
media-renderer-address
|
||||
media-renderer-manufacturer
|
||||
media-renderer-model
|
||||
get-media-renderer
|
||||
media-renderer-dlna?
|
||||
media-renderer-play-uri!
|
||||
media-renderer-next-uri-supported?
|
||||
media-renderer-set-next-uri!
|
||||
media-renderer-pause!
|
||||
media-renderer-stop!
|
||||
media-renderer-seek!
|
||||
media-renderer-status
|
||||
media-renderer-position
|
||||
media-renderer-volume
|
||||
media-renderer-set-volume!
|
||||
media-renderer-muted?
|
||||
media-renderer-set-muted!
|
||||
transport-position?
|
||||
transport-position-track
|
||||
transport-position-seconds
|
||||
transport-position-duration
|
||||
transport-position-uri)
|
||||
|
||||
|
||||
|
||||
(define (get-media-renderer filter-name)
|
||||
(let ((fnm (string-downcase (string-trim filter-name))))
|
||||
(let ((ms (filter (λ (x)
|
||||
(let ((nm (string-downcase (media-renderer-name x))))
|
||||
;(displayln (format "string-contains? '~a' '~a' = ~a" nm fnm (string-contains? nm fnm)))
|
||||
(string-contains? nm fnm)))
|
||||
(query-media-renderers))))
|
||||
(if (null? ms)
|
||||
#f
|
||||
(car ms)))))
|
||||
|
||||
(define (media-renderer? value)
|
||||
(and (upnp-device? value)
|
||||
(eq? (upnp-device-kind value) 'media-renderer)))
|
||||
|
||||
(define (media-renderer-name v)
|
||||
(and (media-renderer? v) (upnp-device-name v)))
|
||||
|
||||
(define (media-renderer-address v)
|
||||
(and (media-renderer? v) (upnp-device-address v)))
|
||||
|
||||
(define (media-renderer-manufacturer v)
|
||||
(and (media-renderer? v) (upnp-device-manufacturer v)))
|
||||
|
||||
(define (media-renderer-model v)
|
||||
(and (media-renderer? v) (upnp-device-model v)))
|
||||
|
||||
(define (media-renderer-dlna? value)
|
||||
(unless (media-renderer? value)
|
||||
(raise-argument-error 'media-renderer-dlna? "media-renderer?" value))
|
||||
(and (upnp-device-property value 'x_dlnadoc #f) #t))
|
||||
|
||||
(define (check-media-renderer who value)
|
||||
(unless (media-renderer? value)
|
||||
(raise-argument-error who "media-renderer?" value)))
|
||||
|
||||
(define (required-service who renderer kind)
|
||||
(check-media-renderer who renderer)
|
||||
(let ([service (upnp-device-service renderer kind)])
|
||||
(unless service
|
||||
(raise-arguments-error
|
||||
who
|
||||
"media renderer does not provide the required UPnP service"
|
||||
"renderer" (upnp-device-name renderer)
|
||||
"service" kind))
|
||||
service))
|
||||
|
||||
(define (query-media-renderers #:interface [interface #f]
|
||||
#:dns? [dns? #f]
|
||||
#:dlna-only? [dlna-only? #f])
|
||||
(unless (boolean? dlna-only?)
|
||||
(raise-argument-error 'query-media-renderers "boolean?" dlna-only?))
|
||||
(let ([renderers
|
||||
(query-upnp-devices 'media-renderer
|
||||
#:interface interface
|
||||
#:dns? dns?)])
|
||||
(if dlna-only?
|
||||
(filter media-renderer-dlna? renderers)
|
||||
renderers)))
|
||||
|
||||
;; Return whether the renderer advertises SetNextAVTransportURI. Reading the
|
||||
;; service description is cached by the generic service layer.
|
||||
(define (media-renderer-next-uri-supported? renderer)
|
||||
(upnp-service-supports-action?
|
||||
(required-service 'media-renderer-next-uri-supported?
|
||||
renderer
|
||||
'av-transport)
|
||||
"SetNextAVTransportURI"))
|
||||
|
||||
;; Set the resource that should play after the current resource. Supporting
|
||||
;; renderers can prefetch this URI and may therefore make the transition
|
||||
;; seamless.
|
||||
(define (media-renderer-set-next-uri! renderer uri #:metadata [metadata ""])
|
||||
(let ([transport (required-service 'media-renderer-set-next-uri!
|
||||
renderer
|
||||
'av-transport)])
|
||||
(unless (upnp-service-supports-action? transport "SetNextAVTransportURI")
|
||||
(raise-arguments-error
|
||||
'media-renderer-set-next-uri!
|
||||
"media renderer does not support preloading a next URI"
|
||||
"renderer" (upnp-device-name renderer)))
|
||||
(av-transport-set-next-uri! transport uri #:metadata metadata)))
|
||||
|
||||
;; Start a resource and optionally preload the following resource before
|
||||
;; playback starts. Setting the next URI first gives the renderer the maximum
|
||||
;; amount of time to buffer it.
|
||||
(define (media-renderer-play-uri! renderer uri
|
||||
#:metadata [metadata ""]
|
||||
#:next-uri [next-uri #f]
|
||||
#:next-metadata [next-metadata ""])
|
||||
(unless (or (not next-uri) (string? next-uri))
|
||||
(raise-argument-error 'media-renderer-play-uri!
|
||||
"(or/c #f string?)"
|
||||
next-uri))
|
||||
(let ([transport (required-service 'media-renderer-play-uri!
|
||||
renderer
|
||||
'av-transport)])
|
||||
(av-transport-set-uri! transport uri #:metadata metadata)
|
||||
(when next-uri
|
||||
(unless (upnp-service-supports-action? transport "SetNextAVTransportURI")
|
||||
(raise-arguments-error
|
||||
'media-renderer-play-uri!
|
||||
"media renderer does not support preloading a next URI"
|
||||
"renderer" (upnp-device-name renderer)))
|
||||
(av-transport-set-next-uri! transport
|
||||
next-uri
|
||||
#:metadata next-metadata))
|
||||
(av-transport-play! transport)))
|
||||
|
||||
(define (media-renderer-pause! renderer)
|
||||
(av-transport-pause!
|
||||
(required-service 'media-renderer-pause! renderer 'av-transport)))
|
||||
|
||||
(define (media-renderer-stop! renderer)
|
||||
(av-transport-stop!
|
||||
(required-service 'media-renderer-stop! renderer 'av-transport)))
|
||||
|
||||
(define (media-renderer-seek! renderer seconds)
|
||||
(av-transport-seek!
|
||||
(required-service 'media-renderer-seek! renderer 'av-transport)
|
||||
seconds))
|
||||
|
||||
(define (media-renderer-status renderer)
|
||||
(av-transport-status
|
||||
(required-service 'media-renderer-status renderer 'av-transport)))
|
||||
|
||||
(define (media-renderer-position renderer)
|
||||
(av-transport-position
|
||||
(required-service 'media-renderer-position renderer 'av-transport)))
|
||||
|
||||
(define (media-renderer-volume renderer)
|
||||
(rendering-control-volume
|
||||
(required-service 'media-renderer-volume renderer 'rendering-control)))
|
||||
|
||||
(define (media-renderer-set-volume! renderer volume)
|
||||
(rendering-control-set-volume!
|
||||
(required-service 'media-renderer-set-volume!
|
||||
renderer
|
||||
'rendering-control)
|
||||
volume))
|
||||
|
||||
(define (media-renderer-muted? renderer)
|
||||
(rendering-control-muted?
|
||||
(required-service 'media-renderer-muted? renderer 'rendering-control)))
|
||||
|
||||
(define (media-renderer-set-muted! renderer muted?)
|
||||
(rendering-control-set-muted!
|
||||
(required-service 'media-renderer-set-muted!
|
||||
renderer
|
||||
'rendering-control)
|
||||
muted?))
|
||||
@@ -0,0 +1,291 @@
|
||||
#lang racket/base
|
||||
|
||||
;; High-level browser for UPnP/DLNA MediaServer devices.
|
||||
;;
|
||||
;; ContentDirectory returns DIDL-Lite XML. This module turns that XML into
|
||||
;; ordinary containers, items and resources, while leaving the raw
|
||||
;; ContentDirectory module available for applications that need exact paging
|
||||
;; information or vendor-specific fields.
|
||||
|
||||
(require net/url
|
||||
racket/list
|
||||
racket/port
|
||||
racket/string
|
||||
xml
|
||||
"device.rkt"
|
||||
"private/model.rkt"
|
||||
"private/xml.rkt"
|
||||
"query.rkt"
|
||||
"services/content-directory.rkt")
|
||||
|
||||
(provide query-media-servers
|
||||
media-server?
|
||||
media-server-root
|
||||
media-server-browse
|
||||
media-container-children
|
||||
media-server-name
|
||||
media-server-address
|
||||
media-server-manufacturer
|
||||
media-server-model
|
||||
get-media-server
|
||||
|
||||
media-entry?
|
||||
media-entry-id
|
||||
media-entry-parent-id
|
||||
media-entry-title
|
||||
media-entry-class
|
||||
media-entry-restricted?
|
||||
|
||||
media-container?
|
||||
media-container-child-count
|
||||
media-container-searchable?
|
||||
|
||||
media-item?
|
||||
media-item-creator
|
||||
media-item-artists
|
||||
media-item-album
|
||||
media-item-genres
|
||||
media-item-date
|
||||
media-item-album-art-uri
|
||||
media-item-resources
|
||||
|
||||
media-resource?
|
||||
media-resource-uri
|
||||
media-resource-protocol-info
|
||||
media-resource-content-type
|
||||
media-resource-size
|
||||
media-resource-duration
|
||||
media-resource-bitrate
|
||||
media-resource-sample-frequency
|
||||
media-resource-bits-per-sample
|
||||
media-resource-channels
|
||||
media-resource-resolution)
|
||||
|
||||
(struct media-entry
|
||||
(id parent-id title class restricted?)
|
||||
#:transparent
|
||||
#:constructor-name make-media-entry)
|
||||
|
||||
(struct media-container media-entry
|
||||
(child-count searchable?)
|
||||
#:transparent
|
||||
#:constructor-name make-media-container)
|
||||
|
||||
(struct media-item media-entry
|
||||
(creator artists album genres date album-art-uri resources)
|
||||
#:transparent
|
||||
#:constructor-name make-media-item)
|
||||
|
||||
(struct media-resource
|
||||
(uri
|
||||
protocol-info
|
||||
content-type
|
||||
size
|
||||
duration
|
||||
bitrate
|
||||
sample-frequency
|
||||
bits-per-sample
|
||||
channels
|
||||
resolution)
|
||||
#:transparent
|
||||
#:constructor-name make-media-resource)
|
||||
|
||||
(define (get-media-server filter-name)
|
||||
(let ((fnm (string-downcase (string-trim filter-name))))
|
||||
(let ((ms (filter (λ (x)
|
||||
(let ((nm (string-downcase (media-server-name x))))
|
||||
;(displayln (format "string-contains? '~a' '~a' = ~a" nm fnm (string-contains? nm fnm)))
|
||||
(string-contains? nm fnm)))
|
||||
(query-media-servers))))
|
||||
(if (null? ms)
|
||||
#f
|
||||
(car ms)))))
|
||||
|
||||
(define (media-server? value)
|
||||
(and (upnp-device? value)
|
||||
(eq? (upnp-device-kind value) 'media-server)
|
||||
(content-directory? (device-content-directory value))))
|
||||
|
||||
(define (media-server-name v)
|
||||
(and (media-server? v) (upnp-device-name v)))
|
||||
|
||||
(define (media-server-address v)
|
||||
(and (media-server? v) (upnp-device-address v)))
|
||||
|
||||
(define (media-server-manufacturer v)
|
||||
(and (media-server? v) (upnp-device-manufacturer v)))
|
||||
|
||||
(define (media-server-model v)
|
||||
(and (media-server? v) (upnp-device-model v)))
|
||||
|
||||
(define (check-media-server who value)
|
||||
(unless (media-server? value)
|
||||
(raise-argument-error who "media-server?" value)))
|
||||
|
||||
(define (query-media-servers #:interface [interface #f]
|
||||
#:dns? [dns? #f])
|
||||
(filter media-server?
|
||||
(query-upnp-devices 'media-server
|
||||
#:interface interface
|
||||
#:dns? dns?)))
|
||||
|
||||
(define (string->boolean value)
|
||||
(and value
|
||||
(or (string=? value "1")
|
||||
(string-ci=? value "true")
|
||||
(string-ci=? value "yes"))))
|
||||
|
||||
(define (string->integer value)
|
||||
(and value
|
||||
(let ([number (string->number value)])
|
||||
(and (exact-integer? number) number))))
|
||||
|
||||
(define (duration->seconds value)
|
||||
(and value
|
||||
(let ([match
|
||||
(regexp-match
|
||||
#px"^([0-9]+):([0-9]{2}):([0-9]{2}(?:[.][0-9]+)?)$"
|
||||
value)])
|
||||
(and match
|
||||
(+ (* 3600 (string->number (cadr match)))
|
||||
(* 60 (string->number (caddr match)))
|
||||
(string->number (cadddr match)))))))
|
||||
|
||||
(define (content-type-from-protocol-info value)
|
||||
(and value
|
||||
(let ([match (regexp-match #px"^[^:]*:[^:]*:([^:]*):" value)])
|
||||
(and match
|
||||
(not (string=? (cadr match) "*"))
|
||||
(cadr match)))))
|
||||
|
||||
(define (absolute-uri base value)
|
||||
(and value
|
||||
(with-handlers ([exn:fail? (lambda (_) value)])
|
||||
(url->string
|
||||
(combine-url/relative (string->url base) value)))))
|
||||
|
||||
(define (child-texts value name)
|
||||
(filter-map
|
||||
(lambda (child)
|
||||
(xexpr-text child #f))
|
||||
(xexpr-child-elements value name)))
|
||||
|
||||
(define (parse-resource value base-url)
|
||||
(let* ([uri (absolute-uri base-url (xexpr-text value #f))]
|
||||
[protocol-info (xexpr-attribute value "protocolInfo" #f)])
|
||||
(and uri
|
||||
(make-media-resource
|
||||
uri
|
||||
protocol-info
|
||||
(content-type-from-protocol-info protocol-info)
|
||||
(string->integer (xexpr-attribute value "size" #f))
|
||||
(duration->seconds (xexpr-attribute value "duration" #f))
|
||||
(string->integer (xexpr-attribute value "bitrate" #f))
|
||||
(string->integer (xexpr-attribute value "sampleFrequency" #f))
|
||||
(string->integer (xexpr-attribute value "bitsPerSample" #f))
|
||||
(string->integer (xexpr-attribute value "nrAudioChannels" #f))
|
||||
(xexpr-attribute value "resolution" #f)))))
|
||||
|
||||
(define (parse-container value)
|
||||
(make-media-container
|
||||
(xexpr-attribute value "id" #f)
|
||||
(xexpr-attribute value "parentID" #f)
|
||||
(or (xexpr-child-text value "title" #f) "")
|
||||
(xexpr-child-text value "class" #f)
|
||||
(string->boolean (xexpr-attribute value "restricted" #f))
|
||||
(string->integer (xexpr-attribute value "childCount" #f))
|
||||
(string->boolean (xexpr-attribute value "searchable" #f))))
|
||||
|
||||
(define (parse-item value base-url)
|
||||
(make-media-item
|
||||
(xexpr-attribute value "id" #f)
|
||||
(xexpr-attribute value "parentID" #f)
|
||||
(or (xexpr-child-text value "title" #f) "")
|
||||
(xexpr-child-text value "class" #f)
|
||||
(string->boolean (xexpr-attribute value "restricted" #f))
|
||||
(xexpr-child-text value "creator" #f)
|
||||
(child-texts value "artist")
|
||||
(xexpr-child-text value "album" #f)
|
||||
(child-texts value "genre")
|
||||
(xexpr-child-text value "date" #f)
|
||||
(absolute-uri base-url (xexpr-child-text value "albumArtURI" #f))
|
||||
(filter-map
|
||||
(lambda (resource)
|
||||
(parse-resource resource base-url))
|
||||
(xexpr-child-elements value "res"))))
|
||||
|
||||
(define (parse-entry value base-url)
|
||||
(cond
|
||||
[(string=? (xexpr-local-name (car value)) "container")
|
||||
(parse-container value)]
|
||||
[(string=? (xexpr-local-name (car value)) "item")
|
||||
(parse-item value base-url)]
|
||||
[else #f]))
|
||||
|
||||
(define (parse-didl-lite content base-url)
|
||||
(if (string=? (string-trim content) "")
|
||||
'()
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exception)
|
||||
(raise
|
||||
(exn:fail
|
||||
(format "unable to parse DIDL-Lite: ~a"
|
||||
(exn-message exception))
|
||||
(current-continuation-marks))))])
|
||||
(call-with-input-string
|
||||
content
|
||||
(lambda (in)
|
||||
(let* ([document (read-xml in)]
|
||||
[root (xml->xexpr (document-element document))])
|
||||
(filter-map
|
||||
(lambda (child)
|
||||
(and (xexpr-element? child)
|
||||
(parse-entry child base-url)))
|
||||
(xexpr-children root))))))))
|
||||
|
||||
(define (container-id value)
|
||||
(cond
|
||||
[(string? value) value]
|
||||
[(media-container? value)
|
||||
(or (media-entry-id value)
|
||||
(raise-arguments-error
|
||||
'media-server-browse
|
||||
"media container has no object id"
|
||||
"container" value))]
|
||||
[else
|
||||
(raise-argument-error
|
||||
'media-server-browse
|
||||
"(or/c string? media-container?)"
|
||||
value)]))
|
||||
|
||||
(define (browse-base-url server)
|
||||
(or (upnp-device-location server)
|
||||
(format "http://~a/" (upnp-device-address server))))
|
||||
|
||||
(define (media-server-browse server [container "0"]
|
||||
#:start [start 0]
|
||||
#:count [count 0])
|
||||
(check-media-server 'media-server-browse server)
|
||||
(let* ([directory (device-content-directory server)]
|
||||
[result
|
||||
(content-directory-browse
|
||||
directory
|
||||
(container-id container)
|
||||
#:start start
|
||||
#:count count)])
|
||||
(parse-didl-lite
|
||||
(content-result-content result)
|
||||
(browse-base-url server))))
|
||||
|
||||
(define (media-server-root server #:start [start 0] #:count [count 0])
|
||||
(media-server-browse server "0" #:start start #:count count))
|
||||
|
||||
(define (media-container-children server container
|
||||
#:start [start 0]
|
||||
#:count [count 0])
|
||||
(unless (media-container? container)
|
||||
(raise-argument-error 'media-container-children
|
||||
"media-container?"
|
||||
container))
|
||||
(media-server-browse server container #:start start #:count count))
|
||||
@@ -0,0 +1,32 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Internal data structures shared by the UPnP modules. Constructors are
|
||||
;; intentionally kept out of the public interface; users receive these values
|
||||
;; through discovery and description functions.
|
||||
|
||||
(provide (struct-out upnp-service)
|
||||
(struct-out upnp-device))
|
||||
|
||||
(struct upnp-service
|
||||
(service-type
|
||||
service-id
|
||||
scpd-url
|
||||
control-url
|
||||
event-sub-url)
|
||||
#:transparent)
|
||||
|
||||
(struct upnp-device
|
||||
(udn
|
||||
device-type
|
||||
friendly-name
|
||||
manufacturer
|
||||
model-name
|
||||
model-number
|
||||
serial-number
|
||||
location
|
||||
address
|
||||
dns-name
|
||||
services
|
||||
embedded-devices
|
||||
properties)
|
||||
#:transparent)
|
||||
+119
@@ -0,0 +1,119 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Small namespace-insensitive helpers for Racket x-expressions.
|
||||
;; UPnP documents use default namespaces and SOAP commonly uses prefixes, so
|
||||
;; matching by local element or attribute name keeps parsers independent of
|
||||
;; namespace prefixes.
|
||||
|
||||
(require racket/list
|
||||
racket/string)
|
||||
|
||||
(provide xexpr-element?
|
||||
xexpr-local-name
|
||||
xexpr-attributes
|
||||
xexpr-attribute
|
||||
xexpr-children
|
||||
xexpr-child-elements
|
||||
xexpr-child-element
|
||||
xexpr-text
|
||||
xexpr-child-text
|
||||
xexpr-find-descendant)
|
||||
|
||||
(define (xexpr-element? value)
|
||||
(and (pair? value)
|
||||
(symbol? (car value))))
|
||||
|
||||
(define (xexpr-attribute-list? value)
|
||||
(and (list? value)
|
||||
(andmap
|
||||
(lambda (attribute)
|
||||
(and (list? attribute)
|
||||
(= (length attribute) 2)
|
||||
(symbol? (car attribute))
|
||||
(string? (cadr attribute))))
|
||||
value)))
|
||||
|
||||
(define (xexpr-local-name value)
|
||||
(let* ([name (if (symbol? value) (symbol->string value) value)]
|
||||
[parts (and (string? name) (string-split name ":"))])
|
||||
(and parts
|
||||
(string-downcase (last parts)))))
|
||||
|
||||
(define (xexpr-attributes value)
|
||||
(if (not (xexpr-element? value))
|
||||
'()
|
||||
(let ([rest (cdr value)])
|
||||
(if (and (pair? rest)
|
||||
(xexpr-attribute-list? (car rest)))
|
||||
(car rest)
|
||||
'()))))
|
||||
|
||||
(define (xexpr-attribute value name [default #f])
|
||||
(let* ([wanted (xexpr-local-name name)]
|
||||
[attribute
|
||||
(findf
|
||||
(lambda (candidate)
|
||||
(string=? (xexpr-local-name (car candidate)) wanted))
|
||||
(xexpr-attributes value))])
|
||||
(if attribute
|
||||
(cadr attribute)
|
||||
default)))
|
||||
|
||||
(define (xexpr-children value)
|
||||
(if (not (xexpr-element? value))
|
||||
'()
|
||||
(let ([rest (cdr value)])
|
||||
(cond
|
||||
[(null? rest) '()]
|
||||
[(xexpr-attribute-list? (car rest)) (cdr rest)]
|
||||
[else rest]))))
|
||||
|
||||
(define (xexpr-named-element? value name)
|
||||
(and (xexpr-element? value)
|
||||
(string=? (xexpr-local-name (car value))
|
||||
(string-downcase name))))
|
||||
|
||||
(define (xexpr-child-elements value name)
|
||||
(for/list ([child (in-list (xexpr-children value))]
|
||||
#:when (xexpr-named-element? child name))
|
||||
child))
|
||||
|
||||
(define (xexpr-child-element value name [default #f])
|
||||
(let ([elements (xexpr-child-elements value name)])
|
||||
(if (pair? elements)
|
||||
(car elements)
|
||||
default)))
|
||||
|
||||
(define (xexpr-content-text value)
|
||||
(cond
|
||||
[(string? value) value]
|
||||
[(xexpr-element? value)
|
||||
(apply string-append
|
||||
(map xexpr-content-text (xexpr-children value)))]
|
||||
[else ""]))
|
||||
|
||||
(define (xexpr-text value [default #f])
|
||||
(let ([text (string-trim (xexpr-content-text value))])
|
||||
(if (string=? text "")
|
||||
default
|
||||
text)))
|
||||
|
||||
(define (xexpr-child-text value name [default #f])
|
||||
(let ([child (xexpr-child-element value name #f)])
|
||||
(if child
|
||||
(xexpr-text child default)
|
||||
default)))
|
||||
|
||||
(define (xexpr-find-descendant value name [default #f])
|
||||
(cond
|
||||
[(xexpr-named-element? value name) value]
|
||||
[(xexpr-element? value)
|
||||
(let loop ([children (xexpr-children value)])
|
||||
(cond
|
||||
[(null? children) default]
|
||||
[else
|
||||
(let ([result (xexpr-find-descendant (car children) name #f)])
|
||||
(if result
|
||||
result
|
||||
(loop (cdr children))))]))]
|
||||
[else default]))
|
||||
@@ -0,0 +1,192 @@
|
||||
#lang racket/base
|
||||
|
||||
;; High-level, device-oriented UPnP discovery.
|
||||
;;
|
||||
;; query-upnp-devices hides SSDP response grouping and XML retrieval. Device
|
||||
;; kinds are friendly symbols; the original UPnP device-type URN remains
|
||||
;; available through upnp-device-type.
|
||||
|
||||
(require racket/list
|
||||
racket/string
|
||||
"device.rkt"
|
||||
"ssdp.rkt")
|
||||
|
||||
(provide query-upnp-devices
|
||||
upnp-device-kinds
|
||||
upnp-device?
|
||||
upnp-device-kind
|
||||
upnp-device-name
|
||||
upnp-device-udn
|
||||
upnp-device-address
|
||||
upnp-device-dns-name
|
||||
upnp-device-manufacturer
|
||||
upnp-device-model
|
||||
upnp-device-type
|
||||
upnp-device-services)
|
||||
|
||||
(define-logger upnp)
|
||||
|
||||
(define device-kind-table
|
||||
'((media-renderer
|
||||
"MediaRenderer"
|
||||
"Network players, televisions, speakers, receivers and amplifiers")
|
||||
(media-server
|
||||
"MediaServer"
|
||||
"Media servers, NAS devices and media libraries")
|
||||
(internet-gateway
|
||||
"InternetGatewayDevice"
|
||||
"Routers, modems and residential gateways")
|
||||
(printer
|
||||
"printer"
|
||||
"Network printers")
|
||||
(scanner
|
||||
"scanner"
|
||||
"Network document and image scanners")
|
||||
(basic-device
|
||||
"Basic"
|
||||
"Generic UPnP devices")
|
||||
(remote-ui-client
|
||||
"RemoteUIClientDevice"
|
||||
"Devices displaying a remote user interface")
|
||||
(remote-ui-server
|
||||
"RemoteUIServerDevice"
|
||||
"Devices providing a remote user interface")))
|
||||
|
||||
(define (upnp-device-kinds)
|
||||
(for/list ([entry (in-list device-kind-table)])
|
||||
(cons (car entry) (caddr entry))))
|
||||
|
||||
(define (upnp-device-type-name device)
|
||||
(let ([type (upnp-device-type device)])
|
||||
(and type
|
||||
(let ([match
|
||||
(regexp-match
|
||||
#px"(?i:^urn:[^:]+:device:([^:]+):[0-9]+$)"
|
||||
type)])
|
||||
(and match (cadr match))))))
|
||||
|
||||
(define (device-kind-by-name name)
|
||||
(let ([entry
|
||||
(and name
|
||||
(findf
|
||||
(lambda (candidate)
|
||||
(string-ci=? (cadr candidate) name))
|
||||
device-kind-table))])
|
||||
(if entry (car entry) 'unknown)))
|
||||
|
||||
(define (upnp-device-kind device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-kind "upnp-device?" device))
|
||||
(device-kind-by-name (upnp-device-type-name device)))
|
||||
|
||||
(define (upnp-device-name device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-name "upnp-device?" device))
|
||||
(or (upnp-device-friendly-name device)
|
||||
(upnp-device-model-name device)
|
||||
(upnp-device-address device)))
|
||||
|
||||
(define (upnp-device-model device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-model "upnp-device?" device))
|
||||
(let ([name (upnp-device-model-name device)]
|
||||
[number (upnp-device-model-number device)])
|
||||
(cond
|
||||
[(and name number (not (string-ci=? name number)))
|
||||
(string-append name " (" number ")")]
|
||||
[name name]
|
||||
[number number]
|
||||
[else #f])))
|
||||
|
||||
(define (known-device-kind? kind)
|
||||
(or (eq? kind 'unknown)
|
||||
(ormap (lambda (entry) (eq? (car entry) kind))
|
||||
device-kind-table)))
|
||||
|
||||
(define (normalize-kinds value)
|
||||
(let ([kinds
|
||||
(cond
|
||||
[(or (not value) (eq? value 'all)) #f]
|
||||
[(symbol? value) (list value)]
|
||||
[(and (list? value) (andmap symbol? value))
|
||||
(remove-duplicates value)]
|
||||
[else
|
||||
(raise-argument-error
|
||||
'query-upnp-devices
|
||||
"(or/c 'all symbol? (listof symbol?))"
|
||||
value)])])
|
||||
(when kinds
|
||||
(for ([kind (in-list kinds)])
|
||||
(unless (known-device-kind? kind)
|
||||
(raise-arguments-error
|
||||
'query-upnp-devices
|
||||
"unknown device kind"
|
||||
"kind" kind
|
||||
"known kinds" (map car device-kind-table)))))
|
||||
kinds))
|
||||
|
||||
(define (kind-entry kind)
|
||||
(findf (lambda (entry) (eq? (car entry) kind))
|
||||
device-kind-table))
|
||||
|
||||
(define (search-target kinds)
|
||||
(if (and kinds
|
||||
(= (length kinds) 1)
|
||||
(not (eq? (car kinds) 'unknown)))
|
||||
(let ([entry (kind-entry (car kinds))])
|
||||
(format "urn:schemas-upnp-org:device:~a:1" (cadr entry)))
|
||||
"ssdp:all"))
|
||||
|
||||
(define (description-devices responses dns?)
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exception)
|
||||
(log-upnp-warning
|
||||
"unable to read UPnP description ~a: ~a"
|
||||
(ssdp-response-location (car responses) "<unknown>")
|
||||
(exn-message exception))
|
||||
'())])
|
||||
(upnp-device-tree (upnp-describe responses #:dns? dns?))))
|
||||
|
||||
(define (device-key device)
|
||||
(or (upnp-device-udn device)
|
||||
(list (upnp-device-location device)
|
||||
(upnp-device-type device)
|
||||
(upnp-device-friendly-name device))))
|
||||
|
||||
(define (remove-duplicate-devices devices)
|
||||
(let-values ([(result seen)
|
||||
(for/fold ([result '()]
|
||||
[seen (hash)])
|
||||
([device (in-list devices)])
|
||||
(let ([key (device-key device)])
|
||||
(if (hash-has-key? seen key)
|
||||
(values result seen)
|
||||
(values (cons device result)
|
||||
(hash-set seen key #t)))))])
|
||||
(reverse result)))
|
||||
|
||||
(define (kind-selected? device kinds)
|
||||
(or (not kinds)
|
||||
(member (upnp-device-kind device) kinds)))
|
||||
|
||||
;; Discover devices. With one known kind, a targeted M-SEARCH is used. With
|
||||
;; multiple kinds, 'unknown or 'all, one ssdp:all search is used and the parsed
|
||||
;; device tree is filtered afterwards.
|
||||
(define (query-upnp-devices [kinds-value 'all]
|
||||
#:interface [interface #f]
|
||||
#:dns? [dns? #f])
|
||||
(let* ([kinds (normalize-kinds kinds-value)]
|
||||
[responses
|
||||
(ssdp-discover (search-target kinds)
|
||||
#:interface interface)]
|
||||
[groups (ssdp-group-responses responses)]
|
||||
[devices
|
||||
(append-map
|
||||
(lambda (group)
|
||||
(description-devices group dns?))
|
||||
(hash-values groups))]
|
||||
[selected
|
||||
(filter (lambda (device) (kind-selected? device kinds))
|
||||
devices)])
|
||||
(remove-duplicate-devices selected)))
|
||||
@@ -0,0 +1,45 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
(file "../main.rkt")
|
||||
(file "../services/av-transport.rkt")))
|
||||
|
||||
@title{AVTransport}
|
||||
|
||||
@defmodule[@racketmodname[racket-upnp/services/av-transport] #:module-paths ((file "../services/av-transport.rkt"))]
|
||||
|
||||
AVTransport controls the playback state of a MediaRenderer. The media itself
|
||||
is normally fetched by the renderer from the URI supplied by the control
|
||||
point.
|
||||
|
||||
@defproc[(device-av-transport [device upnp-device?]) (or/c #f upnp-service?)]{Returns the device's AVTransport service.}
|
||||
@defproc[(av-transport? [value any/c]) boolean?]{Recognises an AVTransport service.}
|
||||
@defproc[(av-transport-set-uri! [transport av-transport?]
|
||||
[uri string?]
|
||||
[#:metadata metadata string? ""]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0])
|
||||
void?]{Sets the current transport URI and optional DIDL-Lite metadata.}
|
||||
@defproc[(av-transport-play! [transport av-transport?]
|
||||
[#:speed speed any/c 1]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0])
|
||||
void?]{Starts playback.}
|
||||
@defproc[(av-transport-pause! [transport av-transport?]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0]) void?]{Pauses playback.}
|
||||
@defproc[(av-transport-stop! [transport av-transport?]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0]) void?]{Stops playback.}
|
||||
@defproc[(av-transport-seek! [transport av-transport?]
|
||||
[seconds nonnegative-real?]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0]) void?]{Seeks using the UPnP @tt{REL_TIME} unit.}
|
||||
@defproc[(av-transport-status [transport av-transport?]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0]) symbol?]{Returns a state such as @racket['playing], @racket['paused], @racket['stopped], or @racket['unknown].}
|
||||
@defproc[(av-transport-position [transport av-transport?]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0]) transport-position?]{Returns the current track, position, duration, and URI.}
|
||||
|
||||
@section{Position values}
|
||||
|
||||
@defproc[(transport-position? [value any/c]) boolean?]{Recognises an AVTransport position value.}
|
||||
@defproc[(transport-position-track [position transport-position?]) (or/c #f exact-integer?)]{Returns the current track number.}
|
||||
@defproc[(transport-position-seconds [position transport-position?]) (or/c #f nonnegative-real?)]{Returns the current relative position in seconds.}
|
||||
@defproc[(transport-position-duration [position transport-position?]) (or/c #f nonnegative-real?)]{Returns the track duration in seconds.}
|
||||
@defproc[(transport-position-uri [position transport-position?]) (or/c #f string?)]{Returns the current track URI.}
|
||||
@@ -0,0 +1,21 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
(file "../main.rkt")
|
||||
(file "../services/connection-manager.rkt")))
|
||||
|
||||
@title{ConnectionManager}
|
||||
|
||||
@defmodule[@racketmodname[racket-upnp/services/connection-manager] #:module-paths ((file "../services/connection-manager.rkt"))]
|
||||
|
||||
ConnectionManager reports supported transfer protocols and active connection
|
||||
identifiers. For a MediaRenderer, the sink protocol list indicates which media
|
||||
formats the renderer advertises as acceptable.
|
||||
|
||||
@defproc[(device-connection-manager [device upnp-device?]) (or/c #f upnp-service?)]{Returns the device's ConnectionManager service.}
|
||||
@defproc[(connection-manager? [value any/c]) boolean?]{Recognises a ConnectionManager service.}
|
||||
@defproc[(connection-manager-protocols [manager connection-manager?]) any]{Returns two values: source protocol-info strings and sink protocol-info strings.}
|
||||
@defproc[(connection-manager-source-protocols [manager connection-manager?]) (listof string?)]{Returns source protocol-info strings.}
|
||||
@defproc[(connection-manager-sink-protocols [manager connection-manager?]) (listof string?)]{Returns sink protocol-info strings.}
|
||||
@defproc[(connection-manager-connection-ids [manager connection-manager?]) (listof exact-integer?)]{Returns currently advertised connection identifiers.}
|
||||
@@ -0,0 +1,41 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
(file "../main.rkt")
|
||||
(file "../services/content-directory.rkt")))
|
||||
|
||||
@title{ContentDirectory}
|
||||
|
||||
@defmodule[@racketmodname[racket-upnp/services/content-directory] #:module-paths ((file "../services/content-directory.rkt"))]
|
||||
|
||||
ContentDirectory is the low-level media-server service. Its browse and search
|
||||
operations return raw DIDL-Lite XML. Applications that want parsed containers,
|
||||
items, and resource URIs can use @racketmodname[racket-upnp/media-server].
|
||||
|
||||
@defproc[(content-directory? [value any/c]) boolean?]{Recognises a ContentDirectory service.}
|
||||
@defproc[(device-content-directory [device upnp-device?]) (or/c #f upnp-service?)]{Returns the device's ContentDirectory service.}
|
||||
@defproc[(content-directory-browse [directory content-directory?]
|
||||
[object-id string?]
|
||||
[#:metadata? metadata? boolean? #f]
|
||||
[#:filter filter string? "*"]
|
||||
[#:start start exact-nonnegative-integer? 0]
|
||||
[#:count count exact-nonnegative-integer? 0]
|
||||
[#:sort sort string? ""])
|
||||
content-result?]{Browses metadata or direct children and returns raw DIDL-Lite plus paging information.}
|
||||
@defproc[(content-directory-search [directory content-directory?]
|
||||
[container-id string?]
|
||||
[search-criteria string?]
|
||||
[#:filter filter string? "*"]
|
||||
[#:start start exact-nonnegative-integer? 0]
|
||||
[#:count count exact-nonnegative-integer? 0]
|
||||
[#:sort sort string? ""])
|
||||
content-result?]{Searches a media server and returns raw DIDL-Lite plus paging information.}
|
||||
|
||||
@section{Result values}
|
||||
|
||||
@defproc[(content-result? [value any/c]) boolean?]{Recognises a ContentDirectory result.}
|
||||
@defproc[(content-result-content [result content-result?]) string?]{Returns the raw DIDL-Lite XML.}
|
||||
@defproc[(content-result-number-returned [result content-result?]) (or/c #f exact-nonnegative-integer?)]{Returns the number of entries in this page.}
|
||||
@defproc[(content-result-total-matches [result content-result?]) (or/c #f exact-nonnegative-integer?)]{Returns the total number of matching entries.}
|
||||
@defproc[(content-result-update-id [result content-result?]) (or/c #f exact-nonnegative-integer?)]{Returns the ContentDirectory update identifier.}
|
||||
@@ -0,0 +1,33 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
(file "../main.rkt")
|
||||
(file "../media-renderer.rkt")
|
||||
(file "../media-server.rkt")
|
||||
(file "../services/av-transport.rkt")
|
||||
(file "../services/rendering-control.rkt")
|
||||
(file "../services/connection-manager.rkt")
|
||||
(file "../services/content-directory.rkt")))
|
||||
|
||||
@title{Introduction}
|
||||
|
||||
The @racketmodname[racket-upnp] collection implements a small UPnP control
|
||||
point. It discovers devices with SSDP, downloads their device descriptions,
|
||||
and represents devices and services as ordinary Racket values. Unknown
|
||||
vendor-specific device and service types are retained instead of discarded.
|
||||
|
||||
The public interface is divided into layers:
|
||||
|
||||
@itemlist[
|
||||
@item{The @racketmodname[racket-upnp] module provides discovery, device
|
||||
information, generic service inspection, and generic SOAP calls.}
|
||||
@item{Modules in the @tt{racket-upnp/services} subcollection provide
|
||||
typed interfaces for standard UPnP services.}
|
||||
@item{The @racketmodname[racket-upnp/media-renderer] and
|
||||
@racketmodname[racket-upnp/media-server] modules provide convenient
|
||||
device-oriented interfaces.}
|
||||
]
|
||||
|
||||
A normal application can use the device-oriented modules without dealing with
|
||||
SSDP, SOAP, service control URLs, or DIDL-Lite XML directly. The generic layer
|
||||
remains available for inspection and vendor-specific extensions.
|
||||
@@ -0,0 +1,103 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
(file "../main.rkt")))
|
||||
|
||||
@title{UPnP Devices and Services}
|
||||
|
||||
@defmodule[@racketmodname[racket-upnp] #:module-paths ((file "../main.rkt"))]
|
||||
|
||||
The main module provides general UPnP device discovery and a generic service
|
||||
interface.
|
||||
|
||||
@section{Discovering devices}
|
||||
|
||||
@defproc[(query-upnp-devices
|
||||
[kinds (or/c 'all symbol? (listof symbol?)) 'all]
|
||||
[#:interface interface (or/c #f string?) #f]
|
||||
[#:dns? dns? boolean? #f])
|
||||
(listof upnp-device?)]{
|
||||
Discovers and describes matching UPnP devices.
|
||||
|
||||
@racket['all] returns all described devices. A symbol such as
|
||||
@racket['media-renderer] selects one known kind, and a list selects several
|
||||
kinds. When @racket[interface] is a local IPv4 address, SSDP multicast is sent
|
||||
through that interface. Reverse DNS lookup is only attempted when
|
||||
@racket[dns?] is true.
|
||||
}
|
||||
|
||||
@defproc[(upnp-device-kinds) (listof (cons/c symbol? string?))]{
|
||||
Returns the friendly device kinds understood by @racket[query-upnp-devices],
|
||||
together with short descriptions. Devices with an unrecognised device type
|
||||
are classified as @racket['unknown] and retain their original UPnP type.
|
||||
}
|
||||
|
||||
@section{Device values}
|
||||
|
||||
@defproc[(upnp-device? [value any/c]) boolean?]{Recognises a described UPnP device.}
|
||||
@defproc[(upnp-device-kind [device upnp-device?]) symbol?]{Returns a friendly kind such as @racket['media-renderer], @racket['scanner], or @racket['unknown].}
|
||||
@defproc[(upnp-device-name [device upnp-device?]) string?]{Returns the friendly name, with model name and address as fallbacks.}
|
||||
@defproc[(upnp-device-udn [device upnp-device?]) (or/c #f string?)]{Returns the Unique Device Name from the device description.}
|
||||
@defproc[(upnp-device-address [device upnp-device?]) string?]{Returns the address from which the SSDP response was received.}
|
||||
@defproc[(upnp-device-dns-name [device upnp-device?]) (or/c #f string?)]{Returns the optional reverse-DNS name.}
|
||||
@defproc[(upnp-device-manufacturer [device upnp-device?]) (or/c #f string?)]{Returns the advertised manufacturer.}
|
||||
@defproc[(upnp-device-model [device upnp-device?]) (or/c #f string?)]{Returns a combined model name and model number.}
|
||||
@defproc[(upnp-device-type [device upnp-device?]) (or/c #f string?)]{Returns the original device-type URN.}
|
||||
@defproc[(upnp-device-services [device upnp-device?]) (listof upnp-service?)]{Returns the services belonging directly to the device.}
|
||||
|
||||
@section{Generic services}
|
||||
|
||||
@defproc[(upnp-service? [value any/c]) boolean?]{Recognises a UPnP service.}
|
||||
@defproc[(upnp-service-kind [service upnp-service?]) symbol?]{Returns a friendly service kind or @racket['unknown].}
|
||||
@defproc[(upnp-service-type [service upnp-service?]) (or/c #f string?)]{Returns the original service-type URN.}
|
||||
@defproc[(upnp-service-id [service upnp-service?]) (or/c #f string?)]{Returns the advertised service identifier.}
|
||||
@defproc[(upnp-service-kinds) (listof (cons/c symbol? string?))]{Returns the known friendly service kinds and descriptions.}
|
||||
|
||||
@defproc[(upnp-device-service [device upnp-device?] [kind symbol?])
|
||||
(or/c #f upnp-service?)]{
|
||||
Returns the highest advertised version of the requested service kind belonging
|
||||
to @racket[device], or @racket[#f] when the service is absent.
|
||||
}
|
||||
|
||||
@defproc[(upnp-service-actions [service upnp-service?]) (listof string?)]{
|
||||
Downloads the service's SCPD document and returns its advertised action names.
|
||||
The result is cached for the service value.
|
||||
}
|
||||
|
||||
@defproc[(upnp-service-supports-action? [service upnp-service?]
|
||||
[action (or/c string? symbol?)])
|
||||
boolean?]{
|
||||
Reports whether the SCPD advertises @racket[action].
|
||||
}
|
||||
|
||||
@defproc[(upnp-service-call [service upnp-service?]
|
||||
[action (or/c string? symbol?)]
|
||||
[arguments list? '()])
|
||||
hash?]{
|
||||
Invokes a SOAP action. @racket[arguments] is an association list containing
|
||||
UPnP argument names and values. The immutable result hash uses the exact
|
||||
output argument names as string keys. This function is intended for
|
||||
vendor-specific services and standard services for which no typed module has
|
||||
been written.
|
||||
|
||||
A failed SOAP request raises @racket[exn:fail:upnp?].
|
||||
}
|
||||
|
||||
@defproc[(exn:fail:upnp? [value any/c]) boolean?]{Recognises a UPnP SOAP error.}
|
||||
@defproc[(exn:fail:upnp-code [error exn:fail:upnp?]) (or/c #f exact-integer?)]{Returns the numeric UPnP error code, when supplied by the device.}
|
||||
@defproc[(exn:fail:upnp-description [error exn:fail:upnp?]) (or/c #f string?)]{Returns the UPnP error description, when supplied by the device.}
|
||||
|
||||
@section[#:tag "device-discovery-example"]{Example}
|
||||
|
||||
@racketblock[
|
||||
(define renderers
|
||||
(query-upnp-devices 'media-renderer
|
||||
#:interface "10.7.3.118"
|
||||
#:dns? #t))
|
||||
|
||||
(for ([device (in-list renderers)])
|
||||
(printf "~a (~a)\n"
|
||||
(upnp-device-name device)
|
||||
(upnp-device-address device)))
|
||||
]
|
||||
@@ -0,0 +1,51 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
(file "../main.rkt")
|
||||
(file "../media-renderer.rkt")
|
||||
(file "../services/av-transport.rkt")))
|
||||
|
||||
@title{Media Renderer}
|
||||
|
||||
@defmodule[@racketmodname[racket-upnp/media-renderer] #:module-paths ((file "../media-renderer.rkt"))]
|
||||
|
||||
This module hides AVTransport and RenderingControl for common playback code.
|
||||
The returned renderer remains an @racket[upnp-device?], so generic service
|
||||
inspection is still available.
|
||||
|
||||
@defproc[(query-media-renderers [#:interface interface (or/c #f string?) #f]
|
||||
[#:dns? dns? boolean? #f]
|
||||
[#:dlna-only? dlna-only? boolean? #f])
|
||||
(listof upnp-device?)]{
|
||||
Discovers UPnP MediaRenderers. When @racket[dlna-only?] is true, only devices
|
||||
advertising an @tt{X_DLNADOC} value are returned.
|
||||
}
|
||||
|
||||
@defproc[(media-renderer? [value any/c]) boolean?]{Recognises a MediaRenderer device.}
|
||||
@defproc[(media-renderer-dlna? [renderer media-renderer?]) boolean?]{Reports whether the device description advertises a DLNA document identifier.}
|
||||
@defproc[(media-renderer-play-uri! [renderer media-renderer?]
|
||||
[uri string?]
|
||||
[#:metadata metadata string? ""]) void?]{Sets the URI and starts playback.}
|
||||
@defproc[(media-renderer-pause! [renderer media-renderer?]) void?]{Pauses playback.}
|
||||
@defproc[(media-renderer-stop! [renderer media-renderer?]) void?]{Stops playback.}
|
||||
@defproc[(media-renderer-seek! [renderer media-renderer?] [seconds nonnegative-real?]) void?]{Seeks to a relative time.}
|
||||
@defproc[(media-renderer-status [renderer media-renderer?]) symbol?]{Returns the abstracted transport state.}
|
||||
@defproc[(media-renderer-position [renderer media-renderer?]) transport-position?]{Returns current position information.}
|
||||
@defproc[(media-renderer-volume [renderer media-renderer?]) (or/c #f exact-integer?)]{Returns the device-specific volume value.}
|
||||
@defproc[(media-renderer-set-volume! [renderer media-renderer?] [volume (integer-in 0 65535)]) void?]{Sets the device-specific volume value.}
|
||||
@defproc[(media-renderer-muted? [renderer media-renderer?]) boolean?]{Returns the mute state.}
|
||||
@defproc[(media-renderer-set-muted! [renderer media-renderer?] [muted? boolean?]) void?]{Sets the mute state.}
|
||||
|
||||
@section[#:tag "media-renderer-example"]{Example}
|
||||
|
||||
@racketblock[
|
||||
(define renderer
|
||||
(car (query-media-renderers #:interface "10.7.3.118")))
|
||||
|
||||
(media-renderer-play-uri!
|
||||
renderer
|
||||
"http://10.7.3.32:50002/music/track.flac")
|
||||
|
||||
(media-renderer-set-volume! renderer 30)
|
||||
]
|
||||
@@ -0,0 +1,114 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
racket/list
|
||||
(file "../main.rkt")
|
||||
(file "../media-server.rkt")))
|
||||
|
||||
@title{Media Server Browser}
|
||||
|
||||
@defmodule[@racketmodname[racket-upnp/media-server] #:module-paths ((file "../media-server.rkt"))]
|
||||
|
||||
This module turns the DIDL-Lite returned by
|
||||
@racketmodname[racket-upnp/services/content-directory] into ordinary Racket
|
||||
values. Containers are browsed one level at a time; the module does not
|
||||
recursively load an entire media library. This is suitable for a browser that
|
||||
requests children when the user expands a container.
|
||||
|
||||
The hierarchy is the logical hierarchy published by the media server. A server
|
||||
may offer views such as artist, album, genre, and physical folder, so a track
|
||||
can occur in more than one container.
|
||||
|
||||
@section{Browsing}
|
||||
|
||||
@defproc[(query-media-servers [#:interface interface (or/c #f string?) #f]
|
||||
[#:dns? dns? boolean? #f])
|
||||
(listof media-server?)]{
|
||||
Discovers UPnP MediaServer devices that provide a ContentDirectory service.
|
||||
}
|
||||
|
||||
@defproc[(media-server? [value any/c]) boolean?]{
|
||||
Recognises a MediaServer device with a ContentDirectory service.
|
||||
}
|
||||
|
||||
@defproc[(media-server-root [server media-server?]
|
||||
[#:start start exact-nonnegative-integer? 0]
|
||||
[#:count count exact-nonnegative-integer? 0])
|
||||
(listof media-entry?)]{
|
||||
Returns the direct children of ContentDirectory object @tt{0}. The optional
|
||||
paging arguments are passed to ContentDirectory. A count of zero asks the
|
||||
server to return all available children, subject to the server's own limits.
|
||||
}
|
||||
|
||||
@defproc[(media-server-browse [server media-server?]
|
||||
[container (or/c string? media-container?) "0"]
|
||||
[#:start start exact-nonnegative-integer? 0]
|
||||
[#:count count exact-nonnegative-integer? 0])
|
||||
(listof media-entry?)]{
|
||||
Returns the direct children of an object identifier or previously returned
|
||||
container.
|
||||
}
|
||||
|
||||
@defproc[(media-container-children [server media-server?]
|
||||
[container media-container?]
|
||||
[#:start start exact-nonnegative-integer? 0]
|
||||
[#:count count exact-nonnegative-integer? 0])
|
||||
(listof media-entry?)]{
|
||||
Convenience form of @racket[media-server-browse] for a container value.
|
||||
}
|
||||
|
||||
@section{Entries}
|
||||
|
||||
@defproc[(media-entry? [value any/c]) boolean?]{Recognises a media container or media item.}
|
||||
@defproc[(media-entry-id [entry media-entry?]) (or/c #f string?)]{Returns the ContentDirectory object identifier.}
|
||||
@defproc[(media-entry-parent-id [entry media-entry?]) (or/c #f string?)]{Returns the parent object identifier.}
|
||||
@defproc[(media-entry-title [entry media-entry?]) string?]{Returns the displayed title.}
|
||||
@defproc[(media-entry-class [entry media-entry?]) (or/c #f string?)]{Returns the original UPnP class, such as @tt{object.item.audioItem.musicTrack}.}
|
||||
@defproc[(media-entry-restricted? [entry media-entry?]) boolean?]{Reports whether the server marks the object as restricted.}
|
||||
|
||||
@defproc[(media-container? [value any/c]) boolean?]{Recognises a browsable container.}
|
||||
@defproc[(media-container-child-count [container media-container?]) (or/c #f exact-nonnegative-integer?)]{Returns the advertised number of children, when present.}
|
||||
@defproc[(media-container-searchable? [container media-container?]) boolean?]{Reports whether the container is advertised as searchable.}
|
||||
|
||||
@defproc[(media-item? [value any/c]) boolean?]{Recognises a media item.}
|
||||
@defproc[(media-item-creator [item media-item?]) (or/c #f string?)]{Returns the Dublin Core creator.}
|
||||
@defproc[(media-item-artists [item media-item?]) (listof string?)]{Returns the advertised artists.}
|
||||
@defproc[(media-item-album [item media-item?]) (or/c #f string?)]{Returns the album title.}
|
||||
@defproc[(media-item-genres [item media-item?]) (listof string?)]{Returns the advertised genres.}
|
||||
@defproc[(media-item-date [item media-item?]) (or/c #f string?)]{Returns the advertised date without imposing a date format.}
|
||||
@defproc[(media-item-album-art-uri [item media-item?]) (or/c #f string?)]{Returns the album-art URI. Relative URIs are resolved against the device-description URL.}
|
||||
@defproc[(media-item-resources [item media-item?]) (listof media-resource?)]{Returns all playable or retrievable resources. One item may advertise several encodings.}
|
||||
|
||||
@section{Resources}
|
||||
|
||||
@defproc[(media-resource? [value any/c]) boolean?]{Recognises a DIDL-Lite resource.}
|
||||
@defproc[(media-resource-uri [resource media-resource?]) string?]{Returns the resource URI, resolved to an absolute URI where possible.}
|
||||
@defproc[(media-resource-protocol-info [resource media-resource?]) (or/c #f string?)]{Returns the complete UPnP @tt{protocolInfo} value.}
|
||||
@defproc[(media-resource-content-type [resource media-resource?]) (or/c #f string?)]{Returns the content-format portion of @tt{protocolInfo}, such as @tt{audio/flac}.}
|
||||
@defproc[(media-resource-size [resource media-resource?]) (or/c #f exact-nonnegative-integer?)]{Returns the size in bytes.}
|
||||
@defproc[(media-resource-duration [resource media-resource?]) (or/c #f nonnegative-real?)]{Returns the duration in seconds.}
|
||||
@defproc[(media-resource-bitrate [resource media-resource?]) (or/c #f exact-nonnegative-integer?)]{Returns the advertised bitrate in bytes per second, as defined by DIDL-Lite.}
|
||||
@defproc[(media-resource-sample-frequency [resource media-resource?]) (or/c #f exact-nonnegative-integer?)]{Returns the sample frequency in hertz.}
|
||||
@defproc[(media-resource-bits-per-sample [resource media-resource?]) (or/c #f exact-nonnegative-integer?)]{Returns the advertised bits per sample.}
|
||||
@defproc[(media-resource-channels [resource media-resource?]) (or/c #f exact-nonnegative-integer?)]{Returns the number of audio channels.}
|
||||
@defproc[(media-resource-resolution [resource media-resource?]) (or/c #f string?)]{Returns an advertised image or video resolution.}
|
||||
|
||||
@section[#:tag "media-server-example"]{Example}
|
||||
|
||||
@racketblock[
|
||||
(define synology
|
||||
(car (query-media-servers #:interface "10.7.3.118")))
|
||||
|
||||
(define root (media-server-root synology))
|
||||
(define music
|
||||
(findf (lambda (entry)
|
||||
(and (media-container? entry)
|
||||
(string=? (media-entry-title entry) "Muziek")))
|
||||
root))
|
||||
|
||||
(for ([entry (in-list (media-container-children synology music))])
|
||||
(printf "~a: ~a\n"
|
||||
(if (media-container? entry) 'container 'item)
|
||||
(media-entry-title entry)))
|
||||
]
|
||||
@@ -0,0 +1,15 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@title{racket-upnp}
|
||||
@author{Hans Dijkema}
|
||||
|
||||
@include-section["intro.scrbl"]
|
||||
@include-section["main.scrbl"]
|
||||
@include-section["media-renderer.scrbl"]
|
||||
@include-section["media-server.scrbl"]
|
||||
@include-section["av-transport.scrbl"]
|
||||
@include-section["rendering-control.scrbl"]
|
||||
@include-section["connection-manager.scrbl"]
|
||||
@include-section["content-directory.scrbl"]
|
||||
|
||||
@index-section[]
|
||||
@@ -0,0 +1,31 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
(file "../main.rkt")
|
||||
(file "../services/rendering-control.rkt")))
|
||||
|
||||
@title{RenderingControl}
|
||||
|
||||
@defmodule[@racketmodname[racket-upnp/services/rendering-control] #:module-paths ((file "../services/rendering-control.rkt"))]
|
||||
|
||||
RenderingControl manages rendering properties such as volume and mute.
|
||||
|
||||
@defproc[(device-rendering-control [device upnp-device?]) (or/c #f upnp-service?)]{Returns the device's RenderingControl service.}
|
||||
@defproc[(rendering-control? [value any/c]) boolean?]{Recognises a RenderingControl service.}
|
||||
@defproc[(rendering-control-volume [control rendering-control?]
|
||||
[#:channel channel string? "Master"]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0])
|
||||
(or/c #f exact-integer?)]{Returns the device-specific UPnP volume value.}
|
||||
@defproc[(rendering-control-set-volume! [control rendering-control?]
|
||||
[volume (integer-in 0 65535)]
|
||||
[#:channel channel string? "Master"]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0])
|
||||
void?]{Sets the device-specific UPnP volume value. The device's SCPD determines the actual supported maximum.}
|
||||
@defproc[(rendering-control-muted? [control rendering-control?]
|
||||
[#:channel channel string? "Master"]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0]) boolean?]{Returns the mute state.}
|
||||
@defproc[(rendering-control-set-muted! [control rendering-control?]
|
||||
[muted? boolean?]
|
||||
[#:channel channel string? "Master"]
|
||||
[#:instance-id instance-id exact-nonnegative-integer? 0]) void?]{Sets the mute state.}
|
||||
+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")]))))
|
||||
@@ -0,0 +1,188 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Typed interface for the UPnP AVTransport service.
|
||||
|
||||
(require racket/format
|
||||
racket/string
|
||||
"../service.rkt")
|
||||
|
||||
(provide av-transport?
|
||||
device-av-transport
|
||||
av-transport-set-uri!
|
||||
av-transport-set-next-uri!
|
||||
av-transport-play!
|
||||
av-transport-pause!
|
||||
av-transport-stop!
|
||||
av-transport-seek!
|
||||
av-transport-status
|
||||
av-transport-position
|
||||
transport-position?
|
||||
transport-position-track
|
||||
transport-position-seconds
|
||||
transport-position-duration
|
||||
transport-position-uri)
|
||||
|
||||
(struct transport-position
|
||||
(track seconds duration uri)
|
||||
#:transparent
|
||||
#:constructor-name make-transport-position)
|
||||
|
||||
(define (av-transport? value)
|
||||
(and (upnp-service? value)
|
||||
(eq? (upnp-service-kind value) 'av-transport)))
|
||||
|
||||
(define (check-av-transport who value)
|
||||
(unless (av-transport? value)
|
||||
(raise-argument-error who "av-transport?" value)))
|
||||
|
||||
(define (device-av-transport device)
|
||||
(upnp-device-service device 'av-transport))
|
||||
|
||||
(define (result-ref result name [default #f])
|
||||
(hash-ref result name default))
|
||||
|
||||
(define (seconds->upnp-time seconds)
|
||||
(unless (and (real? seconds) (not (negative? seconds)))
|
||||
(raise-argument-error 'av-transport-seek!
|
||||
"nonnegative-real?"
|
||||
seconds))
|
||||
(let* ([total (inexact->exact (floor seconds))]
|
||||
[hours (quotient total 3600)]
|
||||
[remaining (remainder total 3600)]
|
||||
[minutes (quotient remaining 60)]
|
||||
[secs (remainder remaining 60)])
|
||||
(format "~a:~a:~a"
|
||||
(~r hours #:min-width 2 #:pad-string "0")
|
||||
(~r minutes #:min-width 2 #:pad-string "0")
|
||||
(~r secs #:min-width 2 #:pad-string "0"))))
|
||||
|
||||
(define (upnp-time->seconds value)
|
||||
(if (or (not value)
|
||||
(string-ci=? value "NOT_IMPLEMENTED"))
|
||||
#f
|
||||
(let ([match
|
||||
(regexp-match
|
||||
#px"^([0-9]+):([0-9]{2}):([0-9]{2})(?:\\.([0-9]+))?$"
|
||||
value)])
|
||||
(and match
|
||||
(let* ([hours (string->number (cadr match))]
|
||||
[minutes (string->number (caddr match))]
|
||||
[seconds (string->number (cadddr match))]
|
||||
[fraction-text (list-ref match 4)]
|
||||
[fraction
|
||||
(if fraction-text
|
||||
(/ (string->number fraction-text)
|
||||
(expt 10 (string-length fraction-text)))
|
||||
0)])
|
||||
(+ (* hours 3600) (* minutes 60) seconds fraction))))))
|
||||
|
||||
(define (transport-state->symbol value)
|
||||
(cond
|
||||
[(not value) 'unknown]
|
||||
[(string-ci=? value "PLAYING") 'playing]
|
||||
[(string-ci=? value "PAUSED_PLAYBACK") 'paused]
|
||||
[(string-ci=? value "PAUSED_RECORDING") 'paused]
|
||||
[(string-ci=? value "STOPPED") 'stopped]
|
||||
[(string-ci=? value "TRANSITIONING") 'transitioning]
|
||||
[(string-ci=? value "NO_MEDIA_PRESENT") 'no-media]
|
||||
[(string-ci=? value "RECORDING") 'recording]
|
||||
[else 'unknown]))
|
||||
|
||||
(define (av-transport-set-uri! transport uri
|
||||
#:metadata [metadata ""]
|
||||
#:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-set-uri! transport)
|
||||
(unless (string? uri)
|
||||
(raise-argument-error 'av-transport-set-uri! "string?" uri))
|
||||
(unless (string? metadata)
|
||||
(raise-argument-error 'av-transport-set-uri! "string?" metadata))
|
||||
(upnp-service-call
|
||||
transport
|
||||
"SetAVTransportURI"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "CurrentURI" uri)
|
||||
(cons "CurrentURIMetaData" metadata)))
|
||||
(void))
|
||||
|
||||
;; Set the resource that should follow the current AVTransport URI.
|
||||
;;
|
||||
;; SetNextAVTransportURI is optional. Call
|
||||
;; upnp-service-supports-action? when the caller needs to test support before
|
||||
;; attempting the operation. A supporting renderer may prefetch the resource
|
||||
;; to provide a seamless transition.
|
||||
(define (av-transport-set-next-uri! transport uri
|
||||
#:metadata [metadata ""]
|
||||
#:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-set-next-uri! transport)
|
||||
(unless (string? uri)
|
||||
(raise-argument-error 'av-transport-set-next-uri! "string?" uri))
|
||||
(unless (string? metadata)
|
||||
(raise-argument-error 'av-transport-set-next-uri! "string?" metadata))
|
||||
(upnp-service-call
|
||||
transport
|
||||
"SetNextAVTransportURI"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "NextURI" uri)
|
||||
(cons "NextURIMetaData" metadata)))
|
||||
(void))
|
||||
|
||||
(define (av-transport-play! transport
|
||||
#:speed [speed 1]
|
||||
#:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-play! transport)
|
||||
(upnp-service-call
|
||||
transport
|
||||
"Play"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "Speed" speed)))
|
||||
(void))
|
||||
|
||||
(define (av-transport-pause! transport #:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-pause! transport)
|
||||
(upnp-service-call
|
||||
transport
|
||||
"Pause"
|
||||
(list (cons "InstanceID" instance-id)))
|
||||
(void))
|
||||
|
||||
(define (av-transport-stop! transport #:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-stop! transport)
|
||||
(upnp-service-call
|
||||
transport
|
||||
"Stop"
|
||||
(list (cons "InstanceID" instance-id)))
|
||||
(void))
|
||||
|
||||
(define (av-transport-seek! transport seconds #:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-seek! transport)
|
||||
(upnp-service-call
|
||||
transport
|
||||
"Seek"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "Unit" "REL_TIME")
|
||||
(cons "Target" (seconds->upnp-time seconds))))
|
||||
(void))
|
||||
|
||||
(define (av-transport-status transport #:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-status transport)
|
||||
(let ([result
|
||||
(upnp-service-call
|
||||
transport
|
||||
"GetTransportInfo"
|
||||
(list (cons "InstanceID" instance-id)))])
|
||||
(transport-state->symbol
|
||||
(result-ref result "CurrentTransportState" #f))))
|
||||
|
||||
(define (av-transport-position transport #:instance-id [instance-id 0])
|
||||
(check-av-transport 'av-transport-position transport)
|
||||
(let ([result
|
||||
(upnp-service-call
|
||||
transport
|
||||
"GetPositionInfo"
|
||||
(list (cons "InstanceID" instance-id)))])
|
||||
(make-transport-position
|
||||
(let ([track (result-ref result "Track" #f)])
|
||||
(and track (string->number track)))
|
||||
(upnp-time->seconds (result-ref result "RelTime" #f))
|
||||
(upnp-time->seconds (result-ref result "TrackDuration" #f))
|
||||
(result-ref result "TrackURI" #f))))
|
||||
@@ -0,0 +1,53 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Typed interface for the UPnP ConnectionManager service.
|
||||
|
||||
(require racket/list
|
||||
racket/string
|
||||
"../service.rkt")
|
||||
|
||||
(provide connection-manager?
|
||||
device-connection-manager
|
||||
connection-manager-protocols
|
||||
connection-manager-source-protocols
|
||||
connection-manager-sink-protocols
|
||||
connection-manager-connection-ids)
|
||||
|
||||
(define (connection-manager? value)
|
||||
(and (upnp-service? value)
|
||||
(eq? (upnp-service-kind value) 'connection-manager)))
|
||||
|
||||
(define (check-connection-manager who value)
|
||||
(unless (connection-manager? value)
|
||||
(raise-argument-error who "connection-manager?" value)))
|
||||
|
||||
(define (device-connection-manager device)
|
||||
(upnp-device-service device 'connection-manager))
|
||||
|
||||
(define (csv-values value)
|
||||
(if (or (not value) (string=? (string-trim value) ""))
|
||||
'()
|
||||
(for/list ([item (in-list (string-split value ","))])
|
||||
(string-trim item))))
|
||||
|
||||
;; Return two values: the source protocol-info list and the sink protocol-info
|
||||
;; list advertised by the device.
|
||||
(define (connection-manager-protocols manager)
|
||||
(check-connection-manager 'connection-manager-protocols manager)
|
||||
(let ([result (upnp-service-call manager "GetProtocolInfo")])
|
||||
(values (csv-values (hash-ref result "Source" ""))
|
||||
(csv-values (hash-ref result "Sink" "")))))
|
||||
|
||||
(define (connection-manager-source-protocols manager)
|
||||
(let-values ([(source sink) (connection-manager-protocols manager)])
|
||||
source))
|
||||
|
||||
(define (connection-manager-sink-protocols manager)
|
||||
(let-values ([(source sink) (connection-manager-protocols manager)])
|
||||
sink))
|
||||
|
||||
(define (connection-manager-connection-ids manager)
|
||||
(check-connection-manager 'connection-manager-connection-ids manager)
|
||||
(let ([result (upnp-service-call manager "GetCurrentConnectionIDs")])
|
||||
(filter-map string->number
|
||||
(csv-values (hash-ref result "ConnectionIDs" "")))))
|
||||
@@ -0,0 +1,95 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Typed interface for the UPnP ContentDirectory service.
|
||||
;;
|
||||
;; The Result field is returned as raw DIDL-Lite XML. Parsing DIDL-Lite into
|
||||
;; media items belongs in a separate media-server layer.
|
||||
|
||||
(require "../service.rkt")
|
||||
|
||||
(provide content-directory?
|
||||
device-content-directory
|
||||
content-directory-browse
|
||||
content-directory-search
|
||||
content-result?
|
||||
content-result-content
|
||||
content-result-number-returned
|
||||
content-result-total-matches
|
||||
content-result-update-id)
|
||||
|
||||
(struct content-result
|
||||
(content number-returned total-matches update-id)
|
||||
#:transparent
|
||||
#:constructor-name make-content-result)
|
||||
|
||||
(define (content-directory? value)
|
||||
(and (upnp-service? value)
|
||||
(eq? (upnp-service-kind value) 'content-directory)))
|
||||
|
||||
(define (check-content-directory who value)
|
||||
(unless (content-directory? value)
|
||||
(raise-argument-error who "content-directory?" value)))
|
||||
|
||||
(define (device-content-directory device)
|
||||
(upnp-device-service device 'content-directory))
|
||||
|
||||
(define (result-number result name)
|
||||
(let ([value (hash-ref result name #f)])
|
||||
(and value (string->number value))))
|
||||
|
||||
(define (make-browse-result result)
|
||||
(make-content-result
|
||||
(hash-ref result "Result" "")
|
||||
(result-number result "NumberReturned")
|
||||
(result-number result "TotalMatches")
|
||||
(result-number result "UpdateID")))
|
||||
|
||||
(define (check-page-arguments who start count)
|
||||
(unless (exact-nonnegative-integer? start)
|
||||
(raise-argument-error who "exact-nonnegative-integer?" start))
|
||||
(unless (exact-nonnegative-integer? count)
|
||||
(raise-argument-error who "exact-nonnegative-integer?" count)))
|
||||
|
||||
(define (content-directory-browse directory object-id
|
||||
#:metadata? [metadata? #f]
|
||||
#:filter [filter "*"]
|
||||
#:start [start 0]
|
||||
#:count [count 0]
|
||||
#:sort [sort ""])
|
||||
(check-content-directory 'content-directory-browse directory)
|
||||
(unless (string? object-id)
|
||||
(raise-argument-error 'content-directory-browse "string?" object-id))
|
||||
(check-page-arguments 'content-directory-browse start count)
|
||||
(make-browse-result
|
||||
(upnp-service-call
|
||||
directory
|
||||
"Browse"
|
||||
(list (cons "ObjectID" object-id)
|
||||
(cons "BrowseFlag"
|
||||
(if metadata? "BrowseMetadata" "BrowseDirectChildren"))
|
||||
(cons "Filter" filter)
|
||||
(cons "StartingIndex" start)
|
||||
(cons "RequestedCount" count)
|
||||
(cons "SortCriteria" sort)))))
|
||||
|
||||
(define (content-directory-search directory container-id search-criteria
|
||||
#:filter [filter "*"]
|
||||
#:start [start 0]
|
||||
#:count [count 0]
|
||||
#:sort [sort ""])
|
||||
(check-content-directory 'content-directory-search directory)
|
||||
(unless (string? container-id)
|
||||
(raise-argument-error 'content-directory-search "string?" container-id))
|
||||
(unless (string? search-criteria)
|
||||
(raise-argument-error 'content-directory-search "string?" search-criteria))
|
||||
(check-page-arguments 'content-directory-search start count)
|
||||
(make-browse-result
|
||||
(upnp-service-call
|
||||
directory
|
||||
"Search"
|
||||
(list (cons "ContainerID" container-id)
|
||||
(cons "SearchCriteria" search-criteria)
|
||||
(cons "Filter" filter)
|
||||
(cons "StartingIndex" start)
|
||||
(cons "RequestedCount" count)
|
||||
(cons "SortCriteria" sort)))))
|
||||
@@ -0,0 +1,87 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Typed interface for the UPnP RenderingControl service.
|
||||
|
||||
(require "../service.rkt")
|
||||
|
||||
(provide rendering-control?
|
||||
device-rendering-control
|
||||
rendering-control-volume
|
||||
rendering-control-set-volume!
|
||||
rendering-control-muted?
|
||||
rendering-control-set-muted!)
|
||||
|
||||
(define (rendering-control? value)
|
||||
(and (upnp-service? value)
|
||||
(eq? (upnp-service-kind value) 'rendering-control)))
|
||||
|
||||
(define (check-rendering-control who value)
|
||||
(unless (rendering-control? value)
|
||||
(raise-argument-error who "rendering-control?" value)))
|
||||
|
||||
(define (device-rendering-control device)
|
||||
(upnp-device-service device 'rendering-control))
|
||||
|
||||
(define (result-ref result name [default #f])
|
||||
(hash-ref result name default))
|
||||
|
||||
(define (upnp-boolean value)
|
||||
(and value
|
||||
(or (string=? value "1")
|
||||
(string-ci=? value "true")
|
||||
(string-ci=? value "yes"))))
|
||||
|
||||
(define (rendering-control-volume control
|
||||
#:channel [channel "Master"]
|
||||
#:instance-id [instance-id 0])
|
||||
(check-rendering-control 'rendering-control-volume control)
|
||||
(let* ([result
|
||||
(upnp-service-call
|
||||
control
|
||||
"GetVolume"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "Channel" channel)))]
|
||||
[volume (result-ref result "CurrentVolume" #f)])
|
||||
(and volume (string->number volume))))
|
||||
|
||||
(define (rendering-control-set-volume! control volume
|
||||
#:channel [channel "Master"]
|
||||
#:instance-id [instance-id 0])
|
||||
(check-rendering-control 'rendering-control-set-volume! control)
|
||||
(unless (and (exact-integer? volume) (<= 0 volume 65535))
|
||||
(raise-argument-error 'rendering-control-set-volume!
|
||||
"(integer-in 0 65535)"
|
||||
volume))
|
||||
(upnp-service-call
|
||||
control
|
||||
"SetVolume"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "Channel" channel)
|
||||
(cons "DesiredVolume" volume)))
|
||||
(void))
|
||||
|
||||
(define (rendering-control-muted? control
|
||||
#:channel [channel "Master"]
|
||||
#:instance-id [instance-id 0])
|
||||
(check-rendering-control 'rendering-control-muted? control)
|
||||
(let ([result
|
||||
(upnp-service-call
|
||||
control
|
||||
"GetMute"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "Channel" channel)))])
|
||||
(upnp-boolean (result-ref result "CurrentMute" #f))))
|
||||
|
||||
(define (rendering-control-set-muted! control muted?
|
||||
#:channel [channel "Master"]
|
||||
#:instance-id [instance-id 0])
|
||||
(check-rendering-control 'rendering-control-set-muted! control)
|
||||
(unless (boolean? muted?)
|
||||
(raise-argument-error 'rendering-control-set-muted! "boolean?" muted?))
|
||||
(upnp-service-call
|
||||
control
|
||||
"SetMute"
|
||||
(list (cons "InstanceID" instance-id)
|
||||
(cons "Channel" channel)
|
||||
(cons "DesiredMute" muted?)))
|
||||
(void))
|
||||
@@ -0,0 +1,189 @@
|
||||
#lang racket/base
|
||||
|
||||
;; SSDP discovery.
|
||||
;;
|
||||
;; This low-level module sends an M-SEARCH request and returns the individual
|
||||
;; unicast responses. Device descriptions and service descriptions are dealt
|
||||
;; with by higher-level modules.
|
||||
|
||||
(require racket/list
|
||||
racket/string
|
||||
racket/udp)
|
||||
|
||||
(provide ssdp-response?
|
||||
ssdp-response-address
|
||||
ssdp-response-port
|
||||
ssdp-response-header
|
||||
ssdp-response-target
|
||||
ssdp-response-usn
|
||||
ssdp-response-udn
|
||||
ssdp-response-location
|
||||
ssdp-group-responses
|
||||
ssdp-discover)
|
||||
|
||||
(define ssdp-multicast-address "239.255.255.250")
|
||||
(define ssdp-multicast-port 1900)
|
||||
|
||||
(struct ssdp-response
|
||||
(address port status headers raw)
|
||||
#:transparent)
|
||||
|
||||
(define (check-discovery-arguments search-target mx timeout repeat interface ttl user-agent)
|
||||
(unless (and (string? search-target)
|
||||
(not (string=? (string-trim search-target) "")))
|
||||
(raise-argument-error 'ssdp-discover "non-empty-string?" search-target))
|
||||
(unless (and (exact-integer? mx) (<= 1 mx 5))
|
||||
(raise-argument-error 'ssdp-discover "(integer-in 1 5)" mx))
|
||||
(unless (and (real? timeout) (positive? timeout) (>= timeout mx))
|
||||
(raise-argument-error 'ssdp-discover
|
||||
(format "real? greater than or equal to MX (~a)" mx)
|
||||
timeout))
|
||||
(unless (exact-positive-integer? repeat)
|
||||
(raise-argument-error 'ssdp-discover "exact-positive-integer?" repeat))
|
||||
(unless (or (not interface) (string? interface))
|
||||
(raise-argument-error 'ssdp-discover "(or/c #f string?)" interface))
|
||||
(unless (and (exact-integer? ttl) (<= 1 ttl 255))
|
||||
(raise-argument-error 'ssdp-discover "(integer-in 1 255)" ttl))
|
||||
(unless (or (not user-agent) (string? user-agent))
|
||||
(raise-argument-error 'ssdp-discover "(or/c #f string?)" user-agent)))
|
||||
|
||||
(define (make-search-request search-target mx user-agent)
|
||||
(string->bytes/utf-8
|
||||
(string-append
|
||||
"M-SEARCH * HTTP/1.1\r\n"
|
||||
"HOST: " ssdp-multicast-address ":" (number->string ssdp-multicast-port) "\r\n"
|
||||
"MAN: \"ssdp:discover\"\r\n"
|
||||
"MX: " (number->string mx) "\r\n"
|
||||
"ST: " search-target "\r\n"
|
||||
(if user-agent
|
||||
(string-append "USER-AGENT: " user-agent "\r\n")
|
||||
"")
|
||||
"\r\n")))
|
||||
|
||||
(define (parse-headers lines)
|
||||
(for/fold ([headers (hash)])
|
||||
([line (in-list lines)]
|
||||
#:break (string=? line ""))
|
||||
(let ([match (regexp-match #px"^([^:]+):[ \t]*(.*)$" line)])
|
||||
(if match
|
||||
(hash-set headers
|
||||
(string-downcase (string-trim (cadr match)))
|
||||
(string-trim (caddr match)))
|
||||
headers))))
|
||||
|
||||
(define (parse-response packet address port)
|
||||
(let* ([raw (bytes->string/latin-1 packet)]
|
||||
[lines (regexp-split #px"\r?\n" raw)]
|
||||
[status (if (pair? lines) (string-trim (car lines)) "")])
|
||||
(and (regexp-match? #px"^HTTP/1\\.[01][ \t]+200(?:[ \t]|$)" status)
|
||||
(ssdp-response address
|
||||
port
|
||||
status
|
||||
(parse-headers (if (pair? lines) (cdr lines) '()))
|
||||
raw))))
|
||||
|
||||
(define (ssdp-response-header response name [default #f])
|
||||
(unless (ssdp-response? response)
|
||||
(raise-argument-error 'ssdp-response-header "ssdp-response?" response))
|
||||
(unless (or (string? name) (symbol? name))
|
||||
(raise-argument-error 'ssdp-response-header "(or/c string? symbol?)" name))
|
||||
(hash-ref (ssdp-response-headers response)
|
||||
(string-downcase (if (symbol? name) (symbol->string name) name))
|
||||
default))
|
||||
|
||||
(define (ssdp-response-target response [default #f])
|
||||
(ssdp-response-header response 'st default))
|
||||
|
||||
(define (ssdp-response-usn response [default #f])
|
||||
(ssdp-response-header response 'usn default))
|
||||
|
||||
(define (ssdp-response-udn response [default #f])
|
||||
(let ([usn (ssdp-response-usn response #f)])
|
||||
(if usn
|
||||
(car (string-split usn "::"))
|
||||
default)))
|
||||
|
||||
(define (ssdp-response-location response [default #f])
|
||||
(ssdp-response-header response 'location default))
|
||||
|
||||
(define (response-key response)
|
||||
(list (ssdp-response-address response)
|
||||
(ssdp-response-usn response "")
|
||||
(ssdp-response-target response "")
|
||||
(ssdp-response-location response "")))
|
||||
|
||||
(define (receive-responses socket timeout)
|
||||
(let ([buffer (make-bytes 65535)]
|
||||
[deadline (+ (current-inexact-milliseconds) (* timeout 1000.0))])
|
||||
(let loop ([responses '()]
|
||||
[seen (hash)])
|
||||
(let ([remaining (/ (- deadline (current-inexact-milliseconds)) 1000.0)])
|
||||
(if (<= remaining 0)
|
||||
(reverse responses)
|
||||
(let ([received (sync/timeout remaining
|
||||
(udp-receive!-evt socket buffer))])
|
||||
(if (not received)
|
||||
(reverse responses)
|
||||
(let* ([length (car received)]
|
||||
[address (cadr received)]
|
||||
[port (caddr received)]
|
||||
[packet (subbytes buffer 0 length)]
|
||||
[response (parse-response packet address port)]
|
||||
[key (and response (response-key response))])
|
||||
(if (or (not response) (hash-has-key? seen key))
|
||||
(loop responses seen)
|
||||
(loop (cons response responses)
|
||||
(hash-set seen key #t)))))))))))
|
||||
|
||||
;; Group responses by LOCATION so each device-description document only needs
|
||||
;; to be downloaded once.
|
||||
(define (ssdp-group-responses responses)
|
||||
(unless (and (list? responses) (andmap ssdp-response? responses))
|
||||
(raise-argument-error 'ssdp-group-responses
|
||||
"(listof ssdp-response?)"
|
||||
responses))
|
||||
(for/fold ([groups (hash)])
|
||||
([response (in-list responses)])
|
||||
(let ([location (ssdp-response-location response #f)])
|
||||
(if location
|
||||
(hash-update groups location
|
||||
(lambda (group) (cons response group))
|
||||
'())
|
||||
groups))))
|
||||
|
||||
;; Search for a UPnP search target. The default "ssdp:all" returns all
|
||||
;; advertised device and service targets. #:interface may be a local IPv4
|
||||
;; address such as "10.7.3.118" when the machine has multiple interfaces.
|
||||
(define (ssdp-discover [search-target "ssdp:all"]
|
||||
#:mx [mx 2]
|
||||
#:timeout [timeout #f]
|
||||
#:repeat [repeat 2]
|
||||
#:interface [interface #f]
|
||||
#:ttl [ttl 2]
|
||||
#:user-agent [user-agent #f])
|
||||
(let ([effective-timeout (or timeout (+ mx 0.5))])
|
||||
(check-discovery-arguments search-target
|
||||
mx
|
||||
effective-timeout
|
||||
repeat
|
||||
interface
|
||||
ttl
|
||||
user-agent)
|
||||
(let ([socket (udp-open-socket ssdp-multicast-address ssdp-multicast-port)]
|
||||
[request (make-search-request search-target mx user-agent)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(udp-bind! socket interface 0)
|
||||
(udp-multicast-set-interface! socket interface)
|
||||
(udp-multicast-set-ttl! socket ttl)
|
||||
(for ([attempt (in-range repeat)])
|
||||
(udp-send-to socket
|
||||
ssdp-multicast-address
|
||||
ssdp-multicast-port
|
||||
request)
|
||||
(when (< attempt (sub1 repeat))
|
||||
(sleep 0.1)))
|
||||
(receive-responses socket effective-timeout))
|
||||
(lambda ()
|
||||
(udp-close socket))))))
|
||||
@@ -0,0 +1,148 @@
|
||||
#lang racket/base
|
||||
|
||||
(require rackunit
|
||||
racket/port
|
||||
racket/tcp
|
||||
xml
|
||||
upnp/media-server
|
||||
upnp/private/model)
|
||||
|
||||
(define listener (tcp-listen 0 4 #t "127.0.0.1"))
|
||||
(define-values (_local-host port _remote-host _remote-port)
|
||||
(tcp-addresses listener #t))
|
||||
|
||||
(define didl
|
||||
(string-append
|
||||
"<DIDL-Lite xmlns=\"urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/\" "
|
||||
"xmlns:dc=\"http://purl.org/dc/elements/1.1/\" "
|
||||
"xmlns:upnp=\"urn:schemas-upnp-org:metadata-1-0/upnp/\">"
|
||||
"<container id=\"21\" parentID=\"0\" restricted=\"1\" childCount=\"2\" searchable=\"1\">"
|
||||
"<dc:title>Muziek</dc:title>"
|
||||
"<upnp:class>object.container.storageFolder</upnp:class>"
|
||||
"</container>"
|
||||
"<item id=\"100\" parentID=\"21\" restricted=\"1\">"
|
||||
"<dc:title>Allegro</dc:title>"
|
||||
"<dc:creator>Composer</dc:creator>"
|
||||
"<upnp:artist role=\"Performer\">Quartet</upnp:artist>"
|
||||
"<upnp:album>String Quartet</upnp:album>"
|
||||
"<upnp:genre>Classical</upnp:genre>"
|
||||
"<dc:date>2026-07-15</dc:date>"
|
||||
"<upnp:albumArtURI>/cover/100.jpg</upnp:albumArtURI>"
|
||||
"<upnp:class>object.item.audioItem.musicTrack</upnp:class>"
|
||||
"<res protocolInfo=\"http-get:*:audio/flac:DLNA.ORG_PN=FLAC\" "
|
||||
"size=\"123456\" duration=\"00:03:30.500\" bitrate=\"900000\" "
|
||||
"sampleFrequency=\"48000\" bitsPerSample=\"24\" nrAudioChannels=\"2\">"
|
||||
"/stream/100.flac</res>"
|
||||
"<res protocolInfo=\"http-get:*:audio/mpeg:*\">"
|
||||
"http://media.example/100.mp3</res>"
|
||||
"</item>"
|
||||
"</DIDL-Lite>"))
|
||||
|
||||
(define response
|
||||
(string-append
|
||||
"<?xml version=\"1.0\"?>"
|
||||
(xexpr->string
|
||||
`(s:Envelope
|
||||
((xmlns:s "http://schemas.xmlsoap.org/soap/envelope/"))
|
||||
(s:Body
|
||||
()
|
||||
(u:BrowseResponse
|
||||
((xmlns:u "urn:schemas-upnp-org:service:ContentDirectory:1"))
|
||||
(Result () ,didl)
|
||||
(NumberReturned () "2")
|
||||
(TotalMatches () "2")
|
||||
(UpdateID () "143")))))))
|
||||
|
||||
(define server-thread
|
||||
(thread
|
||||
(lambda ()
|
||||
(for ([request-number (in-range 2)])
|
||||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(let loop ()
|
||||
(let ([line (read-line in 'any)])
|
||||
(unless (or (eof-object? line) (string=? line ""))
|
||||
(loop))))
|
||||
(let ([response-bytes (string->bytes/utf-8 response)])
|
||||
(fprintf out
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/xml\r\nContent-Length: ~a\r\nConnection: close\r\n\r\n"
|
||||
(bytes-length response-bytes))
|
||||
(write-bytes response-bytes out)
|
||||
(flush-output out))
|
||||
(close-input-port in)
|
||||
(close-output-port out))))))
|
||||
|
||||
(define directory
|
||||
(upnp-service
|
||||
"urn:schemas-upnp-org:service:ContentDirectory:1"
|
||||
"urn:upnp-org:serviceId:ContentDirectory"
|
||||
#f
|
||||
(format "http://127.0.0.1:~a/control" port)
|
||||
#f))
|
||||
|
||||
(define media-server
|
||||
(upnp-device
|
||||
"uuid:test-server"
|
||||
"urn:schemas-upnp-org:device:MediaServer:1"
|
||||
"Test Media Server"
|
||||
"Test"
|
||||
"Server"
|
||||
#f
|
||||
#f
|
||||
(format "http://127.0.0.1:~a/device.xml" port)
|
||||
"127.0.0.1"
|
||||
#f
|
||||
(list directory)
|
||||
'()
|
||||
(hash)))
|
||||
|
||||
(check-true (media-server? media-server))
|
||||
|
||||
(define entries (media-server-root media-server))
|
||||
(check-equal? (length entries) 2)
|
||||
|
||||
(define music (car entries))
|
||||
(check-true (media-container? music))
|
||||
(check-equal? (media-entry-id music) "21")
|
||||
(check-equal? (media-entry-parent-id music) "0")
|
||||
(check-equal? (media-entry-title music) "Muziek")
|
||||
(check-equal? (media-entry-class music) "object.container.storageFolder")
|
||||
(check-true (media-entry-restricted? music))
|
||||
(check-equal? (media-container-child-count music) 2)
|
||||
(check-true (media-container-searchable? music))
|
||||
|
||||
(define track (cadr entries))
|
||||
(check-true (media-item? track))
|
||||
(check-equal? (media-entry-title track) "Allegro")
|
||||
(check-equal? (media-item-creator track) "Composer")
|
||||
(check-equal? (media-item-artists track) '("Quartet"))
|
||||
(check-equal? (media-item-album track) "String Quartet")
|
||||
(check-equal? (media-item-genres track) '("Classical"))
|
||||
(check-equal? (media-item-date track) "2026-07-15")
|
||||
(check-equal? (media-item-album-art-uri track)
|
||||
(format "http://127.0.0.1:~a/cover/100.jpg" port))
|
||||
|
||||
(define resources (media-item-resources track))
|
||||
(check-equal? (length resources) 2)
|
||||
|
||||
(define flac (car resources))
|
||||
(check-equal? (media-resource-uri flac)
|
||||
(format "http://127.0.0.1:~a/stream/100.flac" port))
|
||||
(check-equal? (media-resource-content-type flac) "audio/flac")
|
||||
(check-equal? (media-resource-size flac) 123456)
|
||||
(check-= (media-resource-duration flac) 210.5 0.0001)
|
||||
(check-equal? (media-resource-bitrate flac) 900000)
|
||||
(check-equal? (media-resource-sample-frequency flac) 48000)
|
||||
(check-equal? (media-resource-bits-per-sample flac) 24)
|
||||
(check-equal? (media-resource-channels flac) 2)
|
||||
|
||||
(define children (media-container-children media-server music))
|
||||
(check-equal? (length children) 2)
|
||||
|
||||
(define mp3 (cadr resources))
|
||||
(check-equal? (media-resource-uri mp3) "http://media.example/100.mp3")
|
||||
(check-equal? (media-resource-content-type mp3) "audio/mpeg")
|
||||
|
||||
(thread-wait server-thread)
|
||||
(tcp-close listener)
|
||||
|
||||
(displayln "Media-server browser tests passed")
|
||||
@@ -0,0 +1,217 @@
|
||||
#lang racket/base
|
||||
|
||||
(require rackunit
|
||||
racket/port
|
||||
racket/string
|
||||
racket/tcp
|
||||
upnp
|
||||
upnp/media-renderer
|
||||
upnp/services/av-transport
|
||||
upnp/services/connection-manager
|
||||
upnp/services/content-directory
|
||||
upnp/services/rendering-control
|
||||
upnp/private/model)
|
||||
|
||||
(define av1
|
||||
(upnp-service "urn:schemas-upnp-org:service:AVTransport:1"
|
||||
"urn:upnp-org:serviceId:AVTransport"
|
||||
#f #f #f))
|
||||
|
||||
(define av3
|
||||
(upnp-service "urn:schemas-upnp-org:service:AVTransport:3"
|
||||
"urn:upnp-org:serviceId:AVTransport"
|
||||
#f #f #f))
|
||||
|
||||
(define renderer
|
||||
(upnp-device "uuid:test-renderer"
|
||||
"urn:schemas-upnp-org:device:MediaRenderer:1"
|
||||
"Test Renderer"
|
||||
"Test Manufacturer"
|
||||
"Test Model"
|
||||
"1000"
|
||||
#f
|
||||
"http://127.0.0.1/device.xml"
|
||||
"127.0.0.1"
|
||||
#f
|
||||
(list av1 av3)
|
||||
'()
|
||||
(hash "x_dlnadoc" "DMR-1.50")))
|
||||
|
||||
(check-eq? (upnp-device-kind renderer) 'media-renderer)
|
||||
(check-equal? (upnp-device-name renderer) "Test Renderer")
|
||||
(check-equal? (upnp-device-model renderer) "Test Model (1000)")
|
||||
(check-eq? (upnp-device-service renderer 'av-transport) av3)
|
||||
(check-true (media-renderer? renderer))
|
||||
(check-true (media-renderer-dlna? renderer))
|
||||
(check-not-false (assoc 'media-renderer (upnp-device-kinds)))
|
||||
(check-not-false (assoc 'av-transport (upnp-service-kinds)))
|
||||
(check-not-false (assoc 'scan (upnp-service-kinds)))
|
||||
|
||||
(define listener (tcp-listen 0 4 #t "127.0.0.1"))
|
||||
(define-values (_local-host port _remote-host _remote-port)
|
||||
(tcp-addresses listener #t))
|
||||
(define recorded-bodies (box '()))
|
||||
|
||||
(define (read-request in)
|
||||
(let* ([request-line (read-line in 'any)]
|
||||
[headers
|
||||
(let loop ([headers (hash)])
|
||||
(let ([line (read-line in 'any)])
|
||||
(cond
|
||||
[(or (eof-object? line) (string=? line "")) headers]
|
||||
[else
|
||||
(let ([match (regexp-match #px"^([^:]+):[ \t]*(.*)$" line)])
|
||||
(loop
|
||||
(if match
|
||||
(hash-set headers
|
||||
(string-downcase (cadr match))
|
||||
(caddr match))
|
||||
headers)))])))]
|
||||
[content-length
|
||||
(string->number (hash-ref headers "content-length" "0"))]
|
||||
[body
|
||||
(if (and content-length (positive? content-length))
|
||||
(read-string content-length in)
|
||||
"")])
|
||||
(values request-line headers body)))
|
||||
|
||||
(define (soap-response action content)
|
||||
(string-append
|
||||
"<?xml version=\"1.0\"?>"
|
||||
"<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\">"
|
||||
"<s:Body><u:" action "Response xmlns:u=\"urn:test\">"
|
||||
content
|
||||
"</u:" action "Response></s:Body></s:Envelope>"))
|
||||
|
||||
(define scpd
|
||||
(string-append
|
||||
"<?xml version=\"1.0\"?>"
|
||||
"<scpd xmlns=\"urn:schemas-upnp-org:service-1-0\"><actionList>"
|
||||
"<action><name>SetAVTransportURI</name></action>"
|
||||
"<action><name>Play</name></action>"
|
||||
"<action><name>Pause</name></action>"
|
||||
"<action><name>GetTransportInfo</name></action>"
|
||||
"<action><name>GetPositionInfo</name></action>"
|
||||
"</actionList></scpd>"))
|
||||
|
||||
(define fault
|
||||
(string-append
|
||||
"<?xml version=\"1.0\"?>"
|
||||
"<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\">"
|
||||
"<s:Body><s:Fault><detail><UPnPError>"
|
||||
"<errorCode>701</errorCode><errorDescription>Transition not available</errorDescription>"
|
||||
"</UPnPError></detail></s:Fault></s:Body></s:Envelope>"))
|
||||
|
||||
(define (response-for request-line headers)
|
||||
(let ([action (hash-ref headers "soapaction" "")])
|
||||
(cond
|
||||
[(regexp-match? #rx"GET /avtransport.xml" request-line)
|
||||
(values 200 scpd)]
|
||||
[(regexp-match? #rx"GetTransportInfo" action)
|
||||
(values 200
|
||||
(soap-response
|
||||
"GetTransportInfo"
|
||||
"<CurrentTransportState>PLAYING</CurrentTransportState><CurrentTransportStatus>OK</CurrentTransportStatus><CurrentSpeed>1</CurrentSpeed>"))]
|
||||
[(regexp-match? #rx"GetPositionInfo" action)
|
||||
(values 200
|
||||
(soap-response
|
||||
"GetPositionInfo"
|
||||
"<Track>2</Track><TrackDuration>00:03:30</TrackDuration><RelTime>00:01:15.5</RelTime><TrackURI>http://example/test.flac</TrackURI>"))]
|
||||
[(regexp-match? #rx"GetVolume" action)
|
||||
(values 200 (soap-response "GetVolume" "<CurrentVolume>37</CurrentVolume>"))]
|
||||
[(regexp-match? #rx"GetProtocolInfo" action)
|
||||
(values 200
|
||||
(soap-response
|
||||
"GetProtocolInfo"
|
||||
"<Source>http-get:*:audio/flac:*</Source><Sink>http-get:*:audio/mpeg:*, http-get:*:audio/flac:*</Sink>"))]
|
||||
[(regexp-match? #rx"GetCurrentConnectionIDs" action)
|
||||
(values 200
|
||||
(soap-response
|
||||
"GetCurrentConnectionIDs"
|
||||
"<ConnectionIDs>0,2</ConnectionIDs>"))]
|
||||
[(regexp-match? #rx"Browse" action)
|
||||
(values 200
|
||||
(soap-response
|
||||
"Browse"
|
||||
"<Result><DIDL-Lite/></Result><NumberReturned>1</NumberReturned><TotalMatches>4</TotalMatches><UpdateID>9</UpdateID>"))]
|
||||
[(regexp-match? #rx"FaultAction" action)
|
||||
(values 500 fault)]
|
||||
[else
|
||||
(let ([match (regexp-match #px"#([^\"]+)\"?$" action)])
|
||||
(values 200 (soap-response (if match (cadr match) "Action") "")))])))
|
||||
|
||||
(define server
|
||||
(thread
|
||||
(lambda ()
|
||||
(for ([request-number (in-range 10)])
|
||||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(let-values ([(request-line headers body) (read-request in)])
|
||||
(set-box! recorded-bodies (cons body (unbox recorded-bodies)))
|
||||
(let-values ([(status response) (response-for request-line headers)])
|
||||
(let ([response-bytes (string->bytes/utf-8 response)])
|
||||
(fprintf out
|
||||
"HTTP/1.1 ~a ~a\r\nContent-Type: text/xml\r\nContent-Length: ~a\r\nConnection: close\r\n\r\n"
|
||||
status
|
||||
(if (= status 200) "OK" "Internal Server Error")
|
||||
(bytes-length response-bytes))
|
||||
(write-bytes response-bytes out)
|
||||
(flush-output out))))
|
||||
(close-input-port in)
|
||||
(close-output-port out))))))
|
||||
|
||||
(define control-url (format "http://127.0.0.1:~a/control" port))
|
||||
(define scpd-url (format "http://127.0.0.1:~a/avtransport.xml" port))
|
||||
(define av
|
||||
(upnp-service "urn:schemas-upnp-org:service:AVTransport:1"
|
||||
"urn:upnp-org:serviceId:AVTransport"
|
||||
scpd-url control-url #f))
|
||||
(define rendering
|
||||
(upnp-service "urn:schemas-upnp-org:service:RenderingControl:1"
|
||||
"urn:upnp-org:serviceId:RenderingControl"
|
||||
#f control-url #f))
|
||||
(define connection
|
||||
(upnp-service "urn:schemas-upnp-org:service:ConnectionManager:1"
|
||||
"urn:upnp-org:serviceId:ConnectionManager"
|
||||
#f control-url #f))
|
||||
(define directory
|
||||
(upnp-service "urn:schemas-upnp-org:service:ContentDirectory:1"
|
||||
"urn:upnp-org:serviceId:ContentDirectory"
|
||||
#f control-url #f))
|
||||
|
||||
(check-equal? (upnp-service-actions av)
|
||||
'("SetAVTransportURI" "Play" "Pause" "GetTransportInfo" "GetPositionInfo"))
|
||||
(check-true (upnp-service-supports-action? av 'play))
|
||||
(check-eq? (av-transport-status av) 'playing)
|
||||
(let ([position (av-transport-position av)])
|
||||
(check-equal? (transport-position-track position) 2)
|
||||
(check-equal? (transport-position-seconds position) 151/2)
|
||||
(check-equal? (transport-position-duration position) 210)
|
||||
(check-equal? (transport-position-uri position) "http://example/test.flac"))
|
||||
(av-transport-set-uri! av "http://127.0.0.1/test?a=1&b=2")
|
||||
(check-equal? (rendering-control-volume rendering) 37)
|
||||
(rendering-control-set-volume! rendering 300)
|
||||
(let-values ([(source sink) (connection-manager-protocols connection)])
|
||||
(check-equal? source '("http-get:*:audio/flac:*"))
|
||||
(check-equal? sink '("http-get:*:audio/mpeg:*" "http-get:*:audio/flac:*")))
|
||||
(check-equal? (connection-manager-connection-ids connection) '(0 2))
|
||||
(let ([result (content-directory-browse directory "0")])
|
||||
(check-equal? (content-result-content result) "<DIDL-Lite/>")
|
||||
(check-equal? (content-result-number-returned result) 1)
|
||||
(check-equal? (content-result-total-matches result) 4)
|
||||
(check-equal? (content-result-update-id result) 9))
|
||||
(check-exn
|
||||
(lambda (exception)
|
||||
(and (exn:fail:upnp? exception)
|
||||
(equal? (exn:fail:upnp-code exception) "701")
|
||||
(equal? (exn:fail:upnp-description exception) "Transition not available")))
|
||||
(lambda () (upnp-service-call av "FaultAction")))
|
||||
|
||||
(thread-wait server)
|
||||
(tcp-close listener)
|
||||
|
||||
(check-true
|
||||
(ormap (lambda (body)
|
||||
(regexp-match? #rx"http://127.0.0.1/test\\?a=1&b=2" body))
|
||||
(unbox recorded-bodies)))
|
||||
|
||||
(displayln "UPnP tests passed")
|
||||
Reference in New Issue
Block a user