hans/racket-upnp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial import

Browse Source
This commit is contained in:
Hans Dijkema
2026-07-15 18:00:11 +02:00
parent 02d961e53d
commit c6954f5109
29 changed files with 3062 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files
tests/media-server-test.rkt
+148
View File
@@ -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
+217
View File
@@ -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")