From fbff4b9a6e493769fe7c0915479e4a330b9e8ac7 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Thu, 6 Aug 2026 17:44:24 +0200 Subject: [PATCH] Initial import. --- info.rkt | 15 ++ main.rkt | 5 + sonos.rkt | 347 +++++++++++++++++++++++++++++++++++++++ tests/interface-test.rkt | 22 +++ 4 files changed, 389 insertions(+) create mode 100644 info.rkt create mode 100644 main.rkt create mode 100644 sonos.rkt create mode 100644 tests/interface-test.rkt diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..802ed41 --- /dev/null +++ b/info.rkt @@ -0,0 +1,15 @@ +#lang info + +(define collection "racket-sonos") +(define version "0.1.0") +(define pkg-authors '(hnmdijkema)) +(define license 'MIT) +(define pkg-desc + "Sonos topology support built on racket-upnp") +(define deps + '("base" + "racket-upnp" + "simple-log" + "xml-lib")) +(define build-deps + '("rackunit-lib")) diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..570fe6e --- /dev/null +++ b/main.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(require "sonos.rkt") + +(provide (all-from-out "sonos.rkt")) diff --git a/sonos.rkt b/sonos.rkt new file mode 100644 index 0000000..7586115 --- /dev/null +++ b/sonos.rkt @@ -0,0 +1,347 @@ +#lang racket/base + +(require racket/list + racket/string + simple-log + xml + racket-upnp) + +(sl-def-log sonos) + +(provide sonos-device? + sonos-device-name + sonos-groups + (struct-out sonos-group)) + +(struct sonos-group + (id name coordinator-id member-ids + bonded? stereo? grouped? renderer) + #:transparent) + +(define (local-name value) + (let* ((text (format "~a" value)) + (parts (string-split text ":"))) + (string-downcase (last parts)))) + +(define (element? value) + (and (pair? value) + (symbol? (car value)))) + +(define (attribute-list? value) + (and (list? value) + (andmap + (lambda (entry) + (and (list? entry) + (= (length entry) 2) + (symbol? (car entry)) + (string? (cadr entry)))) + value))) + +(define (attributes value) + (if (not (element? value)) + '() + (let ((rest (cdr value))) + (if (and (pair? rest) + (attribute-list? (car rest))) + (car rest) + '())))) + +(define (attribute value name [default #f]) + (let ((entry + (findf + (lambda (candidate) + (string=? (local-name (car candidate)) + (string-downcase name))) + (attributes value)))) + (if entry + (cadr entry) + default))) + +(define (children value) + (if (not (element? value)) + '() + (let ((rest (cdr value))) + (if (and (pair? rest) + (attribute-list? (car rest))) + (cdr rest) + rest)))) + +(define (descendants value name) + (cond + ((not (element? value)) '()) + (else + (append + (if (string=? (local-name (car value)) + (string-downcase name)) + (list value) + '()) + (append-map + (lambda (child) + (descendants child name)) + (children value)))))) + +(define (service-named? service name) + (let ((type (upnp-service-type service))) + (and type + (regexp-match? + (pregexp + (format "(?i:service:~a:)" + (regexp-quote name))) + type)))) + +(define (topology-service device) + (findf + (lambda (service) + (service-named? service + "ZoneGroupTopology")) + (upnp-device-services device))) + +(define (sonos-device? device) + (and + (upnp-device? device) + (or + (topology-service device) + (let ((manufacturer + (upnp-device-manufacturer device)) + (model + (upnp-device-model device))) + (or + (and manufacturer + (string-contains? + (string-downcase manufacturer) + "sonos")) + (and model + (string-contains? + (string-downcase model) + "symfonisk"))))))) + +(define (zone-state->xexpr state) + (xml->xexpr + (document-element + (read-xml + (open-input-string state))))) + +(define (normalize-id value) + (and + value + (let ((match + (regexp-match + #px"(?i:RINCON_[0-9A-F]+)" + value))) + (if match + (string-upcase (car match)) + (regexp-replace + #px"(?i:^uuid:)" + value + ""))))) + +(define (sonos-device-name device) + (unless (sonos-device? device) + (raise-argument-error + 'sonos-device-name + "sonos-device?" + device)) + (let* ((name (upnp-device-name device)) + (match + (and name + (regexp-match + #px"(?i:^(.+?)[ ]+-[ ]+(?:SYMFONISK|Sonos).*$)" + name)))) + (if match + (string-trim (cadr match)) + name))) + +(define (same-device-id? device id) + (let ((udn (normalize-id + (upnp-device-udn device)))) + (and udn id + (string-ci=? udn id)))) + +(define (renderer-for-id devices id) + (findf + (lambda (device) + (and (media-renderer? device) + (same-device-id? device id))) + devices)) + +(define (visible-member? member) + (not (equal? (attribute member + "Invisible" + "0") + "1"))) + +(define (member-channel-map member) + (string-append + (or (attribute member "ChannelMapSet" "") + "") + " " + (or (attribute member "HTSatChanMapSet" "") + "") + " " + (string-join + (for/list ((satellite + (in-list + (descendants member "Satellite")))) + (or (attribute satellite + "HTSatChanMapSet" + "") + "")) + " "))) + +(define (stereo-member? member) + (let ((channel-map + (member-channel-map member))) + (and (regexp-match? #px"(?i:LF)" + channel-map) + (regexp-match? #px"(?i:RF)" + channel-map)))) + +(define (bonded-member? member) + (or (stereo-member? member) + (not + (null? + (descendants member "Satellite"))) + (not + (string=? + (member-channel-map member) + " ")))) + +(define (group-name members bonded? stereo?) + (let* ((visible + (filter visible-member? members)) + (names + (remove-duplicates + (filter + values + (map + (lambda (member) + (attribute member "ZoneName")) + visible)))) + (base + (if (null? names) + "Sonos" + (string-join names " + ")))) + (cond + (stereo? (format "~a (stereo)" base)) + (bonded? (format "~a (bonded)" base)) + (else base)))) + +(define (parse-group value devices) + (let* ((members + (descendants value "ZoneGroupMember")) + (visible + (filter visible-member? members)) + (coordinator-id + (normalize-id + (attribute value "Coordinator"))) + (renderer + (renderer-for-id devices + coordinator-id)) + (bonded? + (ormap bonded-member? members)) + (stereo? + (ormap stereo-member? members))) + (unless renderer + (warn-sonos + "No MediaRenderer found for Sonos coordinator ~a; renderer UDNs=~s" + coordinator-id + (for/list ((device + (in-list + (filter media-renderer? + devices)))) + (upnp-device-udn device)))) + (and + renderer + (sonos-group + (or (attribute value "ID") + coordinator-id) + (group-name members bonded? stereo?) + coordinator-id + (filter + values + (map + (lambda (member) + (normalize-id + (attribute member "UUID"))) + members)) + bonded? + stereo? + (> (length visible) 1) + renderer)))) + +(define (query-topology service devices) + (let* ((response + (upnp-service-call + service + "GetZoneGroupState")) + (state + (hash-ref response + "ZoneGroupState" + #f))) + (dbg-sonos + "ZoneGroupState=~a" + (or state "")) + (if (and state + (not (string=? state ""))) + (let ((groups + (filter-map + (lambda (group) + (parse-group group devices)) + (descendants + (zone-state->xexpr state) + "ZoneGroup")))) + (info-sonos + "Sonos topology returned ~a logical renderer(s): ~s" + (length groups) + (map sonos-group-name groups)) + groups) + '()))) + +(define (sonos-groups devices) + (let ((service + (for*/first + ((device (in-list devices)) + (service + (in-list + (upnp-device-services device))) + #:when + (service-named? + service + "ZoneGroupTopology")) + service))) + (if service + (query-topology service devices) + (begin + (dbg-sonos + "No ZoneGroupTopology service found among ~a UPnP device(s)" + (length devices)) + '())))) + +(module+ test + (require rackunit) + + (define topology + (zone-state->xexpr + (string-append + "" + "" + ""))) + (define groups + (descendants topology "ZoneGroup")) + (define members + (descendants (car groups) + "ZoneGroupMember")) + + (check-equal? (length groups) 1) + (check-equal? (attribute (car groups) "ID") + "group") + (check-true (stereo-member? (car members))) + (check-true (bonded-member? (car members))) + (check-equal? (group-name members #t #t) + "Woonkamer (stereo)") + (check-equal? + (normalize-id + "uuid:RINCON_347E5C3104C601400_MR") + "RINCON_347E5C3104C601400")) diff --git a/tests/interface-test.rkt b/tests/interface-test.rkt new file mode 100644 index 0000000..079bb0c --- /dev/null +++ b/tests/interface-test.rkt @@ -0,0 +1,22 @@ +#lang racket/base + +(require rackunit + "../main.rkt") + +(check-true (procedure? sonos-device?)) +(check-true (procedure? sonos-groups)) + +(define group + (sonos-group + "group" + "Woonkamer (stereo)" + "RINCON_COORDINATOR" + '("RINCON_LEFT" "RINCON_RIGHT") + #t + #t + #f + 'renderer)) + +(check-true (sonos-group? group)) +(check-true (sonos-group-stereo? group)) +(check-false (sonos-group-grouped? group))