racket-sonos/sonos.rkt

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