Initial import

.gitignore

@@ -15,3 +15,7 @@ compiled/
 # Dependency tracking files
 *.dep
 
+*.bak
+/scribblings/*.css
+/scribblings/*.js
+/scribblings/*.html

README.md

@@ -1,3 +1,165 @@
-# racket-dlna
+# Racket UPnP module
 
-DLNA implementation for racket
+This directory contains a small, layered UPnP control-point implementation.
+The public interfaces deliberately hide SSDP, XML, SCPD and SOAP details unless
+the generic service escape hatch is used.
+
+## Module layout
+
+```text
+upnp/main.rkt                         generic public interface
+upnp/media-renderer.rkt               high-level renderer operations
+upnp/media-server.rkt                 high-level MediaServer browser
+upnp/services/av-transport.rkt        playback transport
+upnp/services/rendering-control.rkt   volume and mute
+upnp/services/connection-manager.rkt  protocol and connection information
+upnp/services/content-directory.rkt   media-server browse and search
+upnp/ssdp.rkt                         low-level SSDP discovery
+upnp/device.rkt                       device-description parsing
+upnp/service.rkt                      SCPD inspection and SOAP calls
+```
+
+The collection can be required as `upnp` when the package root is on Racket's
+collection path.
+
+## Generic device discovery
+
+```racket
+#lang racket/base
+
+(require upnp)
+
+(define devices
+  (query-upnp-devices '(media-renderer scanner)
+                      #:interface "10.7.3.118"
+                      #:dns? #t))
+
+(for ([device (in-list devices)])
+  (printf "~a: ~a\n"
+          (upnp-device-kind device)
+          (upnp-device-name device)))
+```
+
+Known friendly device kinds are returned by:
+
+```racket
+(upnp-device-kinds)
+```
+
+Without a kind, all described UPnP devices are returned:
+
+```racket
+(query-upnp-devices)
+```
+
+Unknown vendor-specific device types are retained and classified as
+`'unknown`; their original URN remains available through `upnp-device-type`.
+
+## Service inspection
+
+```racket
+(define renderer (car (query-upnp-devices 'media-renderer)))
+
+(for ([service (in-list (upnp-device-services renderer))])
+  (printf "~a: ~a\n"
+          (upnp-service-kind service)
+          (upnp-service-actions service)))
+```
+
+`upnp-service-call` is the generic escape hatch for standard services that do
+not yet have a typed module and for manufacturer-specific services.
+
+## One module per known service
+
+```racket
+(require upnp/services/av-transport
+         upnp/services/rendering-control)
+
+(define transport (device-av-transport renderer))
+(define rendering (device-rendering-control renderer))
+
+(av-transport-set-uri!
+ transport
+ "http://10.7.3.118:8080/media/test.flac")
+(av-transport-play! transport)
+(rendering-control-set-volume! rendering 30)
+```
+
+The currently implemented typed service modules are:
+
+- `upnp/services/av-transport`
+- `upnp/services/rendering-control`
+- `upnp/services/connection-manager`
+- `upnp/services/content-directory`
+
+A typed service value is still the generic `upnp-service` value. No extra
+wrapper objects or public constructors are needed.
+
+
+## Media-server browser
+
+The higher media-server layer parses ContentDirectory DIDL-Lite into ordinary
+containers, items and resources:
+
+```racket
+(require upnp/media-server)
+
+(define synology
+  (car (query-media-servers #:interface "10.7.3.118")))
+
+(define root (media-server-root synology))
+(define music
+  (findf (lambda (entry)
+           (and (media-container? entry)
+                (string=? (media-entry-title entry) "Muziek")))
+         root))
+
+(define entries (media-container-children synology music))
+
+(for ([entry (in-list entries)])
+  (printf "~a: ~a\n"
+          (if (media-container? entry) 'container 'item)
+          (media-entry-title entry)))
+```
+
+A media item can advertise several resources.  Their URLs are available with
+`media-item-resources` and `media-resource-uri`.  Containers are followed one
+level at a time; the published hierarchy can be a logical artist/album/genre
+view rather than the physical filesystem.
+
+## Media-renderer convenience layer
+
+Normal playback code need not mention AVTransport or SOAP:
+
+```racket
+(require upnp
+         upnp/media-renderer)
+
+(define denon
+  (car (query-media-renderers
+        #:interface "10.7.3.118"
+        #:dns? #t)))
+
+(media-renderer-play-uri!
+ denon
+ "http://10.7.3.118:8080/media/test.flac")
+
+(media-renderer-seek! denon 120)
+(media-renderer-set-volume! denon 30)
+```
+
+`query-media-renderers` returns all UPnP MediaRenderers by default. Add
+`#:dlna-only? #t` to retain only devices advertising `X_DLNADOC`.
+
+A later HTTP media-serving module can implement `play-file!` by publishing a
+local file through Racket's web-server framework and passing the resulting URL
+to `media-renderer-play-uri!`.
+
+## Documentation and tests
+
+The Scribble manual is in `upnp/scribblings/upnp.scrbl`.
+
+The test file `upnp/tests/upnp-test.rkt` uses a local mock HTTP/SOAP server and
+covers service discovery from SCPD, SOAP calls, SOAP faults, AVTransport,
+RenderingControl, ConnectionManager, ContentDirectory and DIDL-Lite media
+server browsing.

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))))

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))))

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))))))

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))))

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/<service>
+
+(require "query.rkt"
+         "service.rkt"
+         "media-renderer.rkt"
+         "media-server.rkt")
+
+(provide
+ (all-from-out
+  "query.rkt"
+  "service.rkt"
+  "media-renderer.rkt"
+  "media-server.rkt"))

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?))

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))

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)

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]))

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) "<unknown>")
+           (exn-message exception))
+          '())])
+    (upnp-device-tree (upnp-describe responses #:dns? dns?))))
+
+(define (device-key device)
+  (or (upnp-device-udn device)
+      (list (upnp-device-location device)
+            (upnp-device-type device)
+            (upnp-device-friendly-name device))))
+
+(define (remove-duplicate-devices devices)
+  (let-values ([(result seen)
+                (for/fold ([result '()]
+                           [seen (hash)])
+                          ([device (in-list devices)])
+                  (let ([key (device-key device)])
+                    (if (hash-has-key? seen key)
+                        (values result seen)
+                        (values (cons device result)
+                                (hash-set seen key #t)))))])
+    (reverse result)))
+
+(define (kind-selected? device kinds)
+  (or (not kinds)
+      (member (upnp-device-kind device) kinds)))
+
+;; Discover devices.  With one known kind, a targeted M-SEARCH is used.  With
+;; multiple kinds, 'unknown or 'all, one ssdp:all search is used and the parsed
+;; device tree is filtered afterwards.
+(define (query-upnp-devices [kinds-value 'all]
+                            #:interface [interface #f]
+                            #:dns? [dns? #f])
+  (let* ([kinds (normalize-kinds kinds-value)]
+         [responses
+          (ssdp-discover (search-target kinds)
+                         #:interface interface)]
+         [groups (ssdp-group-responses responses)]
+         [devices
+          (append-map
+           (lambda (group)
+             (description-devices group dns?))
+           (hash-values groups))]
+         [selected
+          (filter (lambda (device) (kind-selected? device kinds))
+                  devices)])
+    (remove-duplicate-devices selected)))

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.}

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.}

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.}

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.

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)))
+]

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)
+]

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)))
+]

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[]

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.}

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 "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
+                    (xexpr->string document)))))
+
+(define (url-request-target value)
+  (let* ([relative
+          (struct-copy url value
+                       [scheme #f]
+                       [user #f]
+                       [host #f]
+                       [port #f]
+                       [fragment #f])]
+         [target (url->string relative)])
+    (if (string=? target "") "/" target)))
+
+(define (http-status-code status)
+  (let ([match
+         (regexp-match #px"^HTTP/[0-9.]+[ ]+([0-9]{3})(?:[ ]|$)"
+                       (bytes->string/latin-1 status))])
+    (and match (string->number (cadr match)))))
+
+(define (read-response-body in)
+  (dynamic-wind
+    void
+    (lambda () (port->bytes in))
+    (lambda () (close-input-port in))))
+
+(define (send-soap-request service action arguments)
+  (let* ([control-url (upnp-service-control-url service)]
+         [service-type (upnp-service-service-type service)]
+         [action-name (if (symbol? action) (symbol->string action) action)])
+    (unless control-url
+      (raise-arguments-error 'upnp-service-call
+                             "service has no controlURL"
+                             "service" service))
+    (unless service-type
+      (raise-arguments-error 'upnp-service-call
+                             "service has no serviceType"
+                             "service" service))
+    (let* ([url-value (string->url control-url)]
+           [scheme (or (url-scheme url-value) "http")]
+           [ssl? (string-ci=? scheme "https")]
+           [host (url-host url-value)]
+           [port (or (url-port url-value) (if ssl? 443 80))]
+           [body (soap-envelope service-type action-name arguments)]
+           [headers
+            (list "Content-Type: text/xml; charset=\"utf-8\""
+                  (format "SOAPACTION: \"~a#~a\"" service-type action-name)
+                  "Connection: close")])
+      (unless host
+        (raise-arguments-error 'upnp-service-call
+                               "controlURL has no host"
+                               "controlURL" control-url))
+      (let-values ([(status response-headers in)
+                    (http-sendrecv host
+                                   (url-request-target url-value)
+                                   #:ssl? ssl?
+                                   #:port port
+                                   #:method #"POST"
+                                   #:headers headers
+                                   #:data body)])
+        (values (http-status-code status)
+                response-headers
+                (read-response-body in))))))
+
+(define (bytes->xexpr body)
+  (call-with-input-bytes
+   body
+   (lambda (in)
+     (xml->xexpr (document-element (read-xml in))))))
+
+(define (soap-fault-values response)
+  (let* ([fault (xexpr-find-descendant response "Fault" #f)]
+         [code-element (and fault (xexpr-find-descendant fault "errorCode" #f))]
+         [description-element
+          (and fault (xexpr-find-descendant fault "errorDescription" #f))])
+    (values (and code-element (xexpr-text code-element #f))
+            (and description-element (xexpr-text description-element #f)))))
+
+(define (raise-upnp-error service action code description)
+  (raise
+   (exn:fail:upnp
+    (format "UPnP action ~a failed~a: ~a"
+            action
+            (if code (format " with error ~a" code) "")
+            (or description "unknown error"))
+    (current-continuation-marks)
+    code
+    description
+    action
+    service)))
+
+(define (element-local-name value)
+  (let ([parts (string-split (symbol->string (car value)) ":")])
+    (last parts)))
+
+(define (response-result response service action)
+  (let* ([body (xexpr-find-descendant response "Body" #f)]
+         [elements (if body
+                       (filter xexpr-element? (xexpr-children body))
+                       '())]
+         [result-element (and (pair? elements) (car elements))])
+    (cond
+      [(not result-element) (hash)]
+      [(string=? (xexpr-local-name (car result-element)) "fault")
+       (let-values ([(code description) (soap-fault-values response)])
+         (raise-upnp-error service action code description))]
+      [else
+       (for/fold ([result (hash)])
+                 ([value (in-list (xexpr-children result-element))]
+                  #:when (xexpr-element? value))
+         (hash-set result
+                   (element-local-name value)
+                   (or (xexpr-text value #f) "")))])))
+
+(define (body-preview body)
+  (let* ([text (string-trim (bytes->string/utf-8 body #\uFFFD))]
+         [length (string-length text)])
+    (if (> length 300)
+        (string-append (substring text 0 300) "...")
+        text)))
+
+;; Invoke a SOAP action.  arguments is an association list whose keys are the
+;; exact UPnP argument names.  The result is an immutable hash with the exact
+;; output argument names as string keys.
+(define (upnp-service-call service action [arguments '()])
+  (unless (upnp-service? service)
+    (raise-argument-error 'upnp-service-call "upnp-service?" service))
+  (unless (or (string? action) (symbol? action))
+    (raise-argument-error 'upnp-service-call
+                          "(or/c string? symbol?)"
+                          action))
+  (unless (list? arguments)
+    (raise-argument-error 'upnp-service-call "list?" arguments))
+  (let ([action-name (if (symbol? action) (symbol->string action) action)])
+    (let-values ([(status headers body)
+                  (send-soap-request service action-name arguments)])
+      (cond
+        [(and status (<= 200 status 299))
+         (if (zero? (bytes-length body))
+             (hash)
+             (response-result (bytes->xexpr body) service action-name))]
+        [(positive? (bytes-length body))
+         (let-values ([(code description)
+                       (with-handlers
+                           ([exn:fail? (lambda (_) (values #f #f))])
+                         (soap-fault-values (bytes->xexpr body)))])
+           (raise-upnp-error service
+                             action-name
+                             (or code status)
+                             (or description (body-preview body))))]
+        [else
+         (raise-upnp-error service action-name status "empty HTTP response")]))))

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))))

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" "")))))

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)))))

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))

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))))))

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
+   "<DIDL-Lite xmlns=\"urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/\" "
+   "xmlns:dc=\"http://purl.org/dc/elements/1.1/\" "
+   "xmlns:upnp=\"urn:schemas-upnp-org:metadata-1-0/upnp/\">"
+   "<container id=\"21\" parentID=\"0\" restricted=\"1\" childCount=\"2\" searchable=\"1\">"
+   "<dc:title>Muziek</dc:title>"
+   "<upnp:class>object.container.storageFolder</upnp:class>"
+   "</container>"
+   "<item id=\"100\" parentID=\"21\" restricted=\"1\">"
+   "<dc:title>Allegro</dc:title>"
+   "<dc:creator>Composer</dc:creator>"
+   "<upnp:artist role=\"Performer\">Quartet</upnp:artist>"
+   "<upnp:album>String Quartet</upnp:album>"
+   "<upnp:genre>Classical</upnp:genre>"
+   "<dc:date>2026-07-15</dc:date>"
+   "<upnp:albumArtURI>/cover/100.jpg</upnp:albumArtURI>"
+   "<upnp:class>object.item.audioItem.musicTrack</upnp:class>"
+   "<res protocolInfo=\"http-get:*:audio/flac:DLNA.ORG_PN=FLAC\" "
+   "size=\"123456\" duration=\"00:03:30.500\" bitrate=\"900000\" "
+   "sampleFrequency=\"48000\" bitsPerSample=\"24\" nrAudioChannels=\"2\">"
+   "/stream/100.flac</res>"
+   "<res protocolInfo=\"http-get:*:audio/mpeg:*\">"
+   "http://media.example/100.mp3</res>"
+   "</item>"
+   "</DIDL-Lite>"))
+
+(define response
+  (string-append
+   "<?xml version=\"1.0\"?>"
+   (xexpr->string
+    `(s:Envelope
+      ((xmlns:s "http://schemas.xmlsoap.org/soap/envelope/"))
+      (s:Body
+       ()
+       (u:BrowseResponse
+        ((xmlns:u "urn:schemas-upnp-org:service:ContentDirectory:1"))
+        (Result () ,didl)
+        (NumberReturned () "2")
+        (TotalMatches () "2")
+        (UpdateID () "143")))))))
+
+(define server-thread
+  (thread
+   (lambda ()
+     (for ([request-number (in-range 2)])
+       (let-values ([(in out) (tcp-accept listener)])
+         (let loop ()
+         (let ([line (read-line in 'any)])
+           (unless (or (eof-object? line) (string=? line ""))
+             (loop))))
+       (let ([response-bytes (string->bytes/utf-8 response)])
+         (fprintf out
+                  "HTTP/1.1 200 OK\r\nContent-Type: text/xml\r\nContent-Length: ~a\r\nConnection: close\r\n\r\n"
+                  (bytes-length response-bytes))
+         (write-bytes response-bytes out)
+         (flush-output out))
+         (close-input-port in)
+         (close-output-port out))))))
+
+(define directory
+  (upnp-service
+   "urn:schemas-upnp-org:service:ContentDirectory:1"
+   "urn:upnp-org:serviceId:ContentDirectory"
+   #f
+   (format "http://127.0.0.1:~a/control" port)
+   #f))
+
+(define media-server
+  (upnp-device
+   "uuid:test-server"
+   "urn:schemas-upnp-org:device:MediaServer:1"
+   "Test Media Server"
+   "Test"
+   "Server"
+   #f
+   #f
+   (format "http://127.0.0.1:~a/device.xml" port)
+   "127.0.0.1"
+   #f
+   (list directory)
+   '()
+   (hash)))
+
+(check-true (media-server? media-server))
+
+(define entries (media-server-root media-server))
+(check-equal? (length entries) 2)
+
+(define music (car entries))
+(check-true (media-container? music))
+(check-equal? (media-entry-id music) "21")
+(check-equal? (media-entry-parent-id music) "0")
+(check-equal? (media-entry-title music) "Muziek")
+(check-equal? (media-entry-class music) "object.container.storageFolder")
+(check-true (media-entry-restricted? music))
+(check-equal? (media-container-child-count music) 2)
+(check-true (media-container-searchable? music))
+
+(define track (cadr entries))
+(check-true (media-item? track))
+(check-equal? (media-entry-title track) "Allegro")
+(check-equal? (media-item-creator track) "Composer")
+(check-equal? (media-item-artists track) '("Quartet"))
+(check-equal? (media-item-album track) "String Quartet")
+(check-equal? (media-item-genres track) '("Classical"))
+(check-equal? (media-item-date track) "2026-07-15")
+(check-equal? (media-item-album-art-uri track)
+              (format "http://127.0.0.1:~a/cover/100.jpg" port))
+
+(define resources (media-item-resources track))
+(check-equal? (length resources) 2)
+
+(define flac (car resources))
+(check-equal? (media-resource-uri flac)
+              (format "http://127.0.0.1:~a/stream/100.flac" port))
+(check-equal? (media-resource-content-type flac) "audio/flac")
+(check-equal? (media-resource-size flac) 123456)
+(check-= (media-resource-duration flac) 210.5 0.0001)
+(check-equal? (media-resource-bitrate flac) 900000)
+(check-equal? (media-resource-sample-frequency flac) 48000)
+(check-equal? (media-resource-bits-per-sample flac) 24)
+(check-equal? (media-resource-channels flac) 2)
+
+(define children (media-container-children media-server music))
+(check-equal? (length children) 2)
+
+(define mp3 (cadr resources))
+(check-equal? (media-resource-uri mp3) "http://media.example/100.mp3")
+(check-equal? (media-resource-content-type mp3) "audio/mpeg")
+
+(thread-wait server-thread)
+(tcp-close listener)
+
+(displayln "Media-server browser tests passed")

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
+   "<?xml version=\"1.0\"?>"
+   "<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\">"
+   "<s:Body><u:" action "Response xmlns:u=\"urn:test\">"
+   content
+   "</u:" action "Response></s:Body></s:Envelope>"))
+
+(define scpd
+  (string-append
+   "<?xml version=\"1.0\"?>"
+   "<scpd xmlns=\"urn:schemas-upnp-org:service-1-0\"><actionList>"
+   "<action><name>SetAVTransportURI</name></action>"
+   "<action><name>Play</name></action>"
+   "<action><name>Pause</name></action>"
+   "<action><name>GetTransportInfo</name></action>"
+   "<action><name>GetPositionInfo</name></action>"
+   "</actionList></scpd>"))
+
+(define fault
+  (string-append
+   "<?xml version=\"1.0\"?>"
+   "<s:Envelope xmlns:s=\"http://schemas.xmlsoap.org/soap/envelope/\">"
+   "<s:Body><s:Fault><detail><UPnPError>"
+   "<errorCode>701</errorCode><errorDescription>Transition not available</errorDescription>"
+   "</UPnPError></detail></s:Fault></s:Body></s:Envelope>"))
+
+(define (response-for request-line headers)
+  (let ([action (hash-ref headers "soapaction" "")])
+    (cond
+      [(regexp-match? #rx"GET /avtransport.xml" request-line)
+       (values 200 scpd)]
+      [(regexp-match? #rx"GetTransportInfo" action)
+       (values 200
+               (soap-response
+                "GetTransportInfo"
+                "<CurrentTransportState>PLAYING</CurrentTransportState><CurrentTransportStatus>OK</CurrentTransportStatus><CurrentSpeed>1</CurrentSpeed>"))]
+      [(regexp-match? #rx"GetPositionInfo" action)
+       (values 200
+               (soap-response
+                "GetPositionInfo"
+                "<Track>2</Track><TrackDuration>00:03:30</TrackDuration><RelTime>00:01:15.5</RelTime><TrackURI>http://example/test.flac</TrackURI>"))]
+      [(regexp-match? #rx"GetVolume" action)
+       (values 200 (soap-response "GetVolume" "<CurrentVolume>37</CurrentVolume>"))]
+      [(regexp-match? #rx"GetProtocolInfo" action)
+       (values 200
+               (soap-response
+                "GetProtocolInfo"
+                "<Source>http-get:*:audio/flac:*</Source><Sink>http-get:*:audio/mpeg:*, http-get:*:audio/flac:*</Sink>"))]
+      [(regexp-match? #rx"GetCurrentConnectionIDs" action)
+       (values 200
+               (soap-response
+                "GetCurrentConnectionIDs"
+                "<ConnectionIDs>0,2</ConnectionIDs>"))]
+      [(regexp-match? #rx"Browse" action)
+       (values 200
+               (soap-response
+                "Browse"
+                "<Result>&lt;DIDL-Lite/&gt;</Result><NumberReturned>1</NumberReturned><TotalMatches>4</TotalMatches><UpdateID>9</UpdateID>"))]
+      [(regexp-match? #rx"FaultAction" action)
+       (values 500 fault)]
+      [else
+       (let ([match (regexp-match #px"#([^\"]+)\"?$" action)])
+         (values 200 (soap-response (if match (cadr match) "Action") "")))])))
+
+(define server
+  (thread
+   (lambda ()
+     (for ([request-number (in-range 10)])
+       (let-values ([(in out) (tcp-accept listener)])
+         (let-values ([(request-line headers body) (read-request in)])
+           (set-box! recorded-bodies (cons body (unbox recorded-bodies)))
+           (let-values ([(status response) (response-for request-line headers)])
+             (let ([response-bytes (string->bytes/utf-8 response)])
+               (fprintf out
+                        "HTTP/1.1 ~a ~a\r\nContent-Type: text/xml\r\nContent-Length: ~a\r\nConnection: close\r\n\r\n"
+                        status
+                        (if (= status 200) "OK" "Internal Server Error")
+                        (bytes-length response-bytes))
+               (write-bytes response-bytes out)
+               (flush-output out))))
+         (close-input-port in)
+         (close-output-port out))))))
+
+(define control-url (format "http://127.0.0.1:~a/control" port))
+(define scpd-url (format "http://127.0.0.1:~a/avtransport.xml" port))
+(define av
+  (upnp-service "urn:schemas-upnp-org:service:AVTransport:1"
+                "urn:upnp-org:serviceId:AVTransport"
+                scpd-url control-url #f))
+(define rendering
+  (upnp-service "urn:schemas-upnp-org:service:RenderingControl:1"
+                "urn:upnp-org:serviceId:RenderingControl"
+                #f control-url #f))
+(define connection
+  (upnp-service "urn:schemas-upnp-org:service:ConnectionManager:1"
+                "urn:upnp-org:serviceId:ConnectionManager"
+                #f control-url #f))
+(define directory
+  (upnp-service "urn:schemas-upnp-org:service:ContentDirectory:1"
+                "urn:upnp-org:serviceId:ContentDirectory"
+                #f control-url #f))
+
+(check-equal? (upnp-service-actions av)
+              '("SetAVTransportURI" "Play" "Pause" "GetTransportInfo" "GetPositionInfo"))
+(check-true (upnp-service-supports-action? av 'play))
+(check-eq? (av-transport-status av) 'playing)
+(let ([position (av-transport-position av)])
+  (check-equal? (transport-position-track position) 2)
+  (check-equal? (transport-position-seconds position) 151/2)
+  (check-equal? (transport-position-duration position) 210)
+  (check-equal? (transport-position-uri position) "http://example/test.flac"))
+(av-transport-set-uri! av "http://127.0.0.1/test?a=1&b=2")
+(check-equal? (rendering-control-volume rendering) 37)
+(rendering-control-set-volume! rendering 300)
+(let-values ([(source sink) (connection-manager-protocols connection)])
+  (check-equal? source '("http-get:*:audio/flac:*"))
+  (check-equal? sink '("http-get:*:audio/mpeg:*" "http-get:*:audio/flac:*")))
+(check-equal? (connection-manager-connection-ids connection) '(0 2))
+(let ([result (content-directory-browse directory "0")])
+  (check-equal? (content-result-content result) "<DIDL-Lite/>")
+  (check-equal? (content-result-number-returned result) 1)
+  (check-equal? (content-result-total-matches result) 4)
+  (check-equal? (content-result-update-id result) 9))
+(check-exn
+ (lambda (exception)
+   (and (exn:fail:upnp? exception)
+        (equal? (exn:fail:upnp-code exception) "701")
+        (equal? (exn:fail:upnp-description exception) "Transition not available")))
+ (lambda () (upnp-service-call av "FaultAction")))
+
+(thread-wait server)
+(tcp-close listener)
+
+(check-true
+ (ormap (lambda (body)
+          (regexp-match? #rx"http://127.0.0.1/test\\?a=1&amp;b=2" body))
+        (unbox recorded-bodies)))
+
+(displayln "UPnP tests passed")