Initial import.

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

main.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+
+(require "sonos.rkt")
+
+(provide (all-from-out "sonos.rkt"))

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
+      "<ZoneGroups><ZoneGroup ID=\"group\" "
+      "Coordinator=\"RINCON_LEFT\">"
+      "<ZoneGroupMember UUID=\"RINCON_LEFT\" "
+      "ZoneName=\"Woonkamer\" ChannelMapSet=\"LF,RF\"/>"
+      "</ZoneGroup></ZoneGroups>")))
+  (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"))

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