Initial import

2026-07-15 18:00:11 +02:00
parent 02d961e53d
commit c6954f5109
29 changed files with 3062 additions and 2 deletions
@@ -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))))
@@ -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" "")))))
@@ -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)))))
@@ -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))