From c6954f5109c5004114d3dfb3efc6033a77330bd3 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Wed, 15 Jul 2026 18:00:11 +0200 Subject: [PATCH] Initial import --- .gitignore | 4 + README.md | 166 ++++++++++- device.rkt | 158 +++++++++++ examples/example.rkt | 18 ++ examples/media-server-example.rkt | 36 +++ info.rkt | 6 + main.rkt | 23 ++ media-renderer.rkt | 195 +++++++++++++ media-server.rkt | 291 ++++++++++++++++++++ private/model.rkt | 32 +++ private/xml.rkt | 119 ++++++++ query.rkt | 192 +++++++++++++ scribblings/av-transport.scrbl | 45 +++ scribblings/connection-manager.scrbl | 21 ++ scribblings/content-directory.scrbl | 41 +++ scribblings/intro.scrbl | 33 +++ scribblings/main.scrbl | 103 +++++++ scribblings/media-renderer.scrbl | 51 ++++ scribblings/media-server.scrbl | 114 ++++++++ scribblings/racket-upnp.scrbl | 15 + scribblings/rendering-control.scrbl | 31 +++ service.rkt | 393 +++++++++++++++++++++++++++ services/av-transport.rkt | 188 +++++++++++++ services/connection-manager.rkt | 53 ++++ services/content-directory.rkt | 95 +++++++ services/rendering-control.rkt | 87 ++++++ ssdp.rkt | 189 +++++++++++++ tests/media-server-test.rkt | 148 ++++++++++ tests/upnp-test.rkt | 217 +++++++++++++++ 29 files changed, 3062 insertions(+), 2 deletions(-) create mode 100644 device.rkt create mode 100644 examples/example.rkt create mode 100644 examples/media-server-example.rkt create mode 100644 info.rkt create mode 100644 main.rkt create mode 100644 media-renderer.rkt create mode 100644 media-server.rkt create mode 100644 private/model.rkt create mode 100644 private/xml.rkt create mode 100644 query.rkt create mode 100644 scribblings/av-transport.scrbl create mode 100644 scribblings/connection-manager.scrbl create mode 100644 scribblings/content-directory.scrbl create mode 100644 scribblings/intro.scrbl create mode 100644 scribblings/main.scrbl create mode 100644 scribblings/media-renderer.scrbl create mode 100644 scribblings/media-server.scrbl create mode 100644 scribblings/racket-upnp.scrbl create mode 100644 scribblings/rendering-control.scrbl create mode 100644 service.rkt create mode 100644 services/av-transport.rkt create mode 100644 services/connection-manager.rkt create mode 100644 services/content-directory.rkt create mode 100644 services/rendering-control.rkt create mode 100644 ssdp.rkt create mode 100644 tests/media-server-test.rkt create mode 100644 tests/upnp-test.rkt diff --git a/.gitignore b/.gitignore index 39a4f9c..ba0ccfd 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,7 @@ compiled/ # Dependency tracking files *.dep +*.bak +/scribblings/*.css +/scribblings/*.js +/scribblings/*.html diff --git a/README.md b/README.md index 0296379..63a4d06 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,165 @@ -# racket-dlna +# Racket UPnP module -DLNA implementation for racket \ No newline at end of file +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. diff --git a/device.rkt b/device.rkt new file mode 100644 index 0000000..c1abfae --- /dev/null +++ b/device.rkt @@ -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)))) diff --git a/examples/example.rkt b/examples/example.rkt new file mode 100644 index 0000000..aa3f99d --- /dev/null +++ b/examples/example.rkt @@ -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)))) diff --git a/examples/media-server-example.rkt b/examples/media-server-example.rkt new file mode 100644 index 0000000..c131226 --- /dev/null +++ b/examples/media-server-example.rkt @@ -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)))))) diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..77db749 --- /dev/null +++ b/info.rkt @@ -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)))) \ No newline at end of file diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..ae72faa --- /dev/null +++ b/main.rkt @@ -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/ + +(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")) diff --git a/media-renderer.rkt b/media-renderer.rkt new file mode 100644 index 0000000..084511d --- /dev/null +++ b/media-renderer.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?)) diff --git a/media-server.rkt b/media-server.rkt new file mode 100644 index 0000000..cb589dc --- /dev/null +++ b/media-server.rkt @@ -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)) diff --git a/private/model.rkt b/private/model.rkt new file mode 100644 index 0000000..265b3ab --- /dev/null +++ b/private/model.rkt @@ -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) diff --git a/private/xml.rkt b/private/xml.rkt new file mode 100644 index 0000000..8c5a190 --- /dev/null +++ b/private/xml.rkt @@ -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])) diff --git a/query.rkt b/query.rkt new file mode 100644 index 0000000..80fcfca --- /dev/null +++ b/query.rkt @@ -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) "") + (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))) diff --git a/scribblings/av-transport.scrbl b/scribblings/av-transport.scrbl new file mode 100644 index 0000000..c735705 --- /dev/null +++ b/scribblings/av-transport.scrbl @@ -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.} diff --git a/scribblings/connection-manager.scrbl b/scribblings/connection-manager.scrbl new file mode 100644 index 0000000..17fa394 --- /dev/null +++ b/scribblings/connection-manager.scrbl @@ -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.} diff --git a/scribblings/content-directory.scrbl b/scribblings/content-directory.scrbl new file mode 100644 index 0000000..685861a --- /dev/null +++ b/scribblings/content-directory.scrbl @@ -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.} diff --git a/scribblings/intro.scrbl b/scribblings/intro.scrbl new file mode 100644 index 0000000..59cb4d1 --- /dev/null +++ b/scribblings/intro.scrbl @@ -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. diff --git a/scribblings/main.scrbl b/scribblings/main.scrbl new file mode 100644 index 0000000..b939528 --- /dev/null +++ b/scribblings/main.scrbl @@ -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))) +] diff --git a/scribblings/media-renderer.scrbl b/scribblings/media-renderer.scrbl new file mode 100644 index 0000000..c4d3b66 --- /dev/null +++ b/scribblings/media-renderer.scrbl @@ -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) +] diff --git a/scribblings/media-server.scrbl b/scribblings/media-server.scrbl new file mode 100644 index 0000000..73d9d2b --- /dev/null +++ b/scribblings/media-server.scrbl @@ -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))) +] diff --git a/scribblings/racket-upnp.scrbl b/scribblings/racket-upnp.scrbl new file mode 100644 index 0000000..01d4f8e --- /dev/null +++ b/scribblings/racket-upnp.scrbl @@ -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[] diff --git a/scribblings/rendering-control.scrbl b/scribblings/rendering-control.scrbl new file mode 100644 index 0000000..42938f5 --- /dev/null +++ b/scribblings/rendering-control.scrbl @@ -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.} diff --git a/service.rkt b/service.rkt new file mode 100644 index 0000000..0ab4de0 --- /dev/null +++ b/service.rkt @@ -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 "" + (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")])))) diff --git a/services/av-transport.rkt b/services/av-transport.rkt new file mode 100644 index 0000000..9707a82 --- /dev/null +++ b/services/av-transport.rkt @@ -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)))) diff --git a/services/connection-manager.rkt b/services/connection-manager.rkt new file mode 100644 index 0000000..a7bff22 --- /dev/null +++ b/services/connection-manager.rkt @@ -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" ""))))) diff --git a/services/content-directory.rkt b/services/content-directory.rkt new file mode 100644 index 0000000..8026de9 --- /dev/null +++ b/services/content-directory.rkt @@ -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))))) diff --git a/services/rendering-control.rkt b/services/rendering-control.rkt new file mode 100644 index 0000000..bb3c0d5 --- /dev/null +++ b/services/rendering-control.rkt @@ -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)) diff --git a/ssdp.rkt b/ssdp.rkt new file mode 100644 index 0000000..3d803b2 --- /dev/null +++ b/ssdp.rkt @@ -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)))))) diff --git a/tests/media-server-test.rkt b/tests/media-server-test.rkt new file mode 100644 index 0000000..e028b52 --- /dev/null +++ b/tests/media-server-test.rkt @@ -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 + "" + "" + "Muziek" + "object.container.storageFolder" + "" + "" + "Allegro" + "Composer" + "Quartet" + "String Quartet" + "Classical" + "2026-07-15" + "/cover/100.jpg" + "object.item.audioItem.musicTrack" + "" + "/stream/100.flac" + "" + "http://media.example/100.mp3" + "" + "")) + +(define response + (string-append + "" + (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") diff --git a/tests/upnp-test.rkt b/tests/upnp-test.rkt new file mode 100644 index 0000000..5059596 --- /dev/null +++ b/tests/upnp-test.rkt @@ -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 + "" + "" + "" + content + "")) + +(define scpd + (string-append + "" + "" + "SetAVTransportURI" + "Play" + "Pause" + "GetTransportInfo" + "GetPositionInfo" + "")) + +(define fault + (string-append + "" + "" + "" + "701Transition not available" + "")) + +(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" + "PLAYINGOK1"))] + [(regexp-match? #rx"GetPositionInfo" action) + (values 200 + (soap-response + "GetPositionInfo" + "200:03:3000:01:15.5http://example/test.flac"))] + [(regexp-match? #rx"GetVolume" action) + (values 200 (soap-response "GetVolume" "37"))] + [(regexp-match? #rx"GetProtocolInfo" action) + (values 200 + (soap-response + "GetProtocolInfo" + "http-get:*:audio/flac:*http-get:*:audio/mpeg:*, http-get:*:audio/flac:*"))] + [(regexp-match? #rx"GetCurrentConnectionIDs" action) + (values 200 + (soap-response + "GetCurrentConnectionIDs" + "0,2"))] + [(regexp-match? #rx"Browse" action) + (values 200 + (soap-response + "Browse" + "<DIDL-Lite/>149"))] + [(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) "") + (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")