218 lines
8.7 KiB
Racket
218 lines
8.7 KiB
Racket
#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><DIDL-Lite/></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&b=2" body))
|
|
(unbox recorded-bodies)))
|
|
|
|
(displayln "UPnP tests passed")
|