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

logging added.

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-03 14:11:55 +02:00
parent f51729308c
commit cffedd6dbf
6 changed files with 107 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files
info.rkt
+2 -1
View File
@@ -1,7 +1,7 @@
#lang info
(define pkg-authors '(hnmdijkema))
(define version "0.1.3")
(define version "0.1.5")
(define license 'MIT)
(define collection "racket-upnp")
(define pkg-desc "racket-upnp - UpnP and DLNA for racket")
@@ -9,6 +9,7 @@
(define deps
'("base"
"net-lib"
"simple-log"
"racket-mimetypes"
("web-server-lib" #:version "1.10")))
media-file-server.rkt
+21 -5
View File
@@ -7,6 +7,7 @@
;; which media renderers commonly use for probing and seeking.
(require net/url
simple-log
racket/async-channel
racket/file
racket/path
@@ -19,6 +20,8 @@
racket-mimetypes
"didl-lite.rkt")
(sl-def-log upnp-file-server)
(provide start-media-file-server
media-file-server?
media-file-server-url
@@ -156,6 +159,7 @@
listen-ip))
(let-values ([(base-url base-path)
(normalize-base-url 'start-media-file-server url)])
(info-upnp-file-server "Starting media file server url=~a listen-ip=~a" (url->string base-url) (or listen-ip "all interfaces"))
(let* ([publications (make-hash)]
[mime-types (make-hash)]
[lock (make-semaphore 1)]
@@ -165,14 +169,19 @@
(format "racket-upnp-missing-~a" (gensym)))]
[url->path
(lambda (request-url)
(let ([path
(let ([request-path (url-path-string request-url)])
(dbg-upnp-file-server "Resolving media request path=~a" request-path)
(let ([path
(call-with-semaphore
lock
(lambda ()
(hash-ref publications
(url-path-string request-url)
request-path
missing-path)))])
(values path '())))]
(if (equal? path missing-path)
(warn-upnp-file-server "Media request not published path=~a" request-path)
(dbg-upnp-file-server "Media request path=~a maps to file=~a" request-path path))
(values path '()))))]
[path->mime-type
(lambda (path)
(call-with-semaphore
@@ -189,7 +198,8 @@
#:path->headers dlna-response-headers)]
[not-found-dispatcher
(dispatch/servlet
(lambda (_request)
(lambda (request)
(warn-upnp-file-server "Returning 404 for request URI ~a" (url->string (request-uri request)))
(response/full
404
#f
@@ -210,8 +220,10 @@
#:port (url-effective-port base-url))]
[result (sync confirmation)])
(when (exn? result)
(err-upnp-file-server "Could not start media file server: ~a" (exn-message result))
(stop)
(raise result))
(info-upnp-file-server "Media file server started at ~a" (url->string base-url))
(make-media-file-server
base-url
base-path
@@ -265,7 +277,9 @@
'media-file-server-publish!
mime-type
path))))
(url->string publication-url))))
(let ([published-url (url->string publication-url)])
(info-upnp-file-server "Published file=~a url=~a mime-type=~a" path published-url (bytes->string/utf-8 (normalize-mime-type 'media-file-server-publish! mime-type path)))
published-url))))
(define (media-file-server-didl-lite server url
#:title [title #f]
@@ -328,6 +342,7 @@
#:parent-id parent-id))))
(define (media-file-server-unpublish! server url)
(dbg-upnp-file-server "Unpublishing URL ~a" url)
(check-media-file-server 'media-file-server-unpublish! server)
(let-values ([(_publication-url publication-path)
(resolve-publication-url
@@ -354,5 +369,6 @@
(hash-clear! (media-file-server-publications server))
(media-file-server-stop server)))))])
(when stop
(info-upnp-file-server "Stopping media file server at ~a" (media-file-server-url server))
(stop))
(void)))
query.rkt
+19 -4
View File
@@ -7,6 +7,7 @@
;; available through upnp-device-type.
(require racket/list
simple-log
racket/string
"device.rkt"
"ssdp.rkt")
@@ -24,7 +25,7 @@
upnp-device-type
upnp-device-services)
(define-logger upnp)
(sl-def-log upnp-query)
(define device-kind-table
'((media-renderer
@@ -141,7 +142,7 @@
(with-handlers
([exn:fail?
(lambda (exception)
(log-upnp-warning
(warn-upnp-query
"unable to read UPnP description ~a: ~a"
(ssdp-response-location (car responses) "<unknown>")
(exn-message exception))
@@ -175,11 +176,25 @@
;; device tree is filtered afterwards.
(define (query-upnp-devices [kinds-value 'all]
#:interface [interface #f]
#:dns? [dns? #f])
#:dns? [dns? #f]
#:mx [mx 3]
#:timeout [timeout #f]
#:repeat [repeat 3])
(dbg-upnp-query
"Querying UPnP devices kinds=~s interface=~a dns?=~a mx=~a timeout=~a repeat=~a"
kinds-value
(or interface "default")
dns?
mx
(or timeout "default")
repeat)
(let* ([kinds (normalize-kinds kinds-value)]
[responses
(ssdp-discover (search-target kinds)
#:interface interface)]
#:interface interface
#:mx mx
#:timeout timeout
#:repeat repeat)]
[groups (ssdp-group-responses responses)]
[devices
(append-map
scribblings/main.scrbl
+11 -3
View File
@@ -16,15 +16,23 @@ interface.
@defproc[(query-upnp-devices
[kinds (or/c 'all symbol? (listof symbol?)) 'all]
[#:interface interface (or/c #f string?) #f]
[#:dns? dns? boolean? #f])
[#:dns? dns? boolean? #f]
[#:mx mx (integer-in 1 5) 3]
[#:timeout timeout (or/c #f positive-real?) #f]
[#:repeat repeat exact-positive-integer? 3])
(listof upnp-device?)]{
Discovers and describes matching UPnP devices.
@racket['all] returns all described devices. A symbol such as
@racket['media-renderer] selects one known kind, and a list selects several
kinds. When @racket[interface] is a local IPv4 address, SSDP multicast is sent
through that interface. Reverse DNS lookup is only attempted when
@racket[dns?] is true.
through that interface. Reverse DNS lookup is only attempted when @racket[dns?] is true.
@racket[mx] is the SSDP response delay advertised in the M-SEARCH request.
The default receive window is @racket[mx] plus one second. An explicit
@racket[timeout] overrides that receive window and must be at least
@racket[mx]. @racket[repeat] controls how many M-SEARCH requests are sent;
the requests are spaced 250 milliseconds apart.
}
@defproc[(upnp-device-kinds) (listof (cons/c symbol? string?))]{
service.rkt
+13 -3
View File
@@ -7,6 +7,7 @@
;; services and actions.
(require net/http-client
simple-log
net/url
racket/list
racket/port
@@ -15,6 +16,8 @@
"private/model.rkt"
"private/xml.rkt")
(sl-def-log upnp-soap)
(provide upnp-service?
upnp-service-kind
upnp-service-type
@@ -151,6 +154,7 @@
services))))
(define (read-xml-url location)
(dbg-upnp-soap "Reading UPnP XML description from ~a" location)
(call/input-url
(string->url location)
(lambda (url)
@@ -159,6 +163,7 @@
(xml->xexpr (document-element (read-xml in))))))
(define (read-service-actions service)
(dbg-upnp-soap "Reading actions for service ~a" (upnp-service-service-type service))
(let ([location (upnp-service-scpd-url service)])
(unless location
(raise-arguments-error 'upnp-service-actions
@@ -184,6 +189,7 @@
service
(lambda ()
(let ([actions (read-service-actions service)])
(dbg-upnp-soap "Caching ~a actions for service ~a" (length actions) (upnp-service-service-type service))
(hash-set! action-cache service actions)
actions))))))
@@ -291,6 +297,7 @@
(raise-arguments-error 'upnp-service-call
"controlURL has no host"
"controlURL" control-url))
(dbg-upnp-soap "SOAP request action=~a service=~a control-url=~a arguments=~s bytes=~a" action-name service-type control-url arguments (bytes-length body))
(let-values ([(status response-headers in)
(http-sendrecv host
(url-request-target url-value)
@@ -299,9 +306,10 @@
#:method #"POST"
#:headers headers
#:data body)])
(values (http-status-code status)
response-headers
(read-response-body in))))))
(let ([code (http-status-code status)]
[response-body (read-response-body in)])
(dbg-upnp-soap "SOAP response action=~a status=~a bytes=~a" action-name code (bytes-length response-body))
(values code response-headers response-body))))))
(define (bytes->xexpr body)
(call-with-input-bytes
@@ -318,6 +326,7 @@
(and description-element (xexpr-text description-element #f)))))
(define (raise-upnp-error service action code description)
(err-upnp-soap "UPnP action ~a failed, code=~a, description=~a, service=~a" action (or code "unknown") (or description "unknown") (upnp-service-service-type service))
(raise
(exn:fail:upnp
(format "UPnP action ~a failed~a: ~a"
@@ -377,6 +386,7 @@
(send-soap-request service action-name arguments)])
(cond
[(and status (<= 200 status 299))
(dbg-upnp-soap "UPnP action ~a completed successfully" action-name)
(if (zero? (bytes-length body))
(hash)
(response-result (bytes->xexpr body) service action-name))]
ssdp.rkt
+41 -11
View File
@@ -7,6 +7,7 @@
;; with by higher-level modules.
(require racket/list
simple-log
racket/string
racket/udp)
@@ -21,6 +22,8 @@
ssdp-group-responses
ssdp-discover)
(sl-def-log upnp-ssdp)
(define ssdp-multicast-address "239.255.255.250")
(define ssdp-multicast-port 1900)
@@ -112,18 +115,29 @@
(ssdp-response-target response "")
(ssdp-response-location response "")))
(define (receive-responses socket timeout)
(define (receive-responses socket timeout started-at)
(dbg-upnp-ssdp "Waiting up to ~a seconds for SSDP responses" timeout)
(let ([buffer (make-bytes 65535)]
[deadline (+ (current-inexact-milliseconds) (* timeout 1000.0))])
(let loop ([responses '()]
[seen (hash)])
(let ([remaining (/ (- deadline (current-inexact-milliseconds)) 1000.0)])
(if (<= remaining 0)
(reverse responses)
(begin
(dbg-upnp-ssdp
"SSDP receive window closed after ~a ms with ~a unique responses"
(inexact->exact (round (- (current-inexact-milliseconds) started-at)))
(length responses))
(reverse responses))
(let ([received (sync/timeout remaining
(udp-receive!-evt socket buffer))])
(if (not received)
(reverse responses)
(begin
(dbg-upnp-ssdp
"SSDP receive timed out after ~a ms with ~a unique responses"
(inexact->exact (round (- (current-inexact-milliseconds) started-at)))
(length responses))
(reverse responses))
(let* ([length (car received)]
[address (cadr received)]
[port (caddr received)]
@@ -131,9 +145,20 @@
[response (parse-response packet address port)]
[key (and response (response-key response))])
(if (or (not response) (hash-has-key? seen key))
(loop responses seen)
(loop (cons response responses)
(hash-set seen key #t)))))))))))
(begin
(when response
(dbg-upnp-ssdp "Ignoring duplicate SSDP response from ~a:~a (~a)" address port (ssdp-response-usn response "unknown USN")))
(loop responses seen))
(begin
(dbg-upnp-ssdp
"Received SSDP response after ~a ms from ~a:~a, target=~a, location=~a"
(inexact->exact (round (- (current-inexact-milliseconds) started-at)))
address
port
(ssdp-response-target response "unknown")
(ssdp-response-location response "unknown"))
(loop (cons response responses)
(hash-set seen key #t))))))))))))
;; Group responses by LOCATION so each device-description document only needs
;; to be downloaded once.
@@ -155,13 +180,13 @@
;; advertised device and service targets. #:interface may be a local IPv4
;; address such as "10.7.3.118" when the machine has multiple interfaces.
(define (ssdp-discover [search-target "ssdp:all"]
#:mx [mx 2]
#:mx [mx 3]
#:timeout [timeout #f]
#:repeat [repeat 2]
#:repeat [repeat 3]
#:interface [interface #f]
#:ttl [ttl 2]
#:user-agent [user-agent #f])
(let ([effective-timeout (or timeout (+ mx 0.5))])
(let ([effective-timeout (or timeout (+ mx 1.0))])
(check-discovery-arguments search-target
mx
effective-timeout
@@ -169,21 +194,26 @@
interface
ttl
user-agent)
(dbg-upnp-ssdp "Starting SSDP discovery target=~a mx=~a timeout=~a repeat=~a interface=~a ttl=~a" search-target mx effective-timeout repeat (or interface "default") ttl)
(let ([socket (udp-open-socket ssdp-multicast-address ssdp-multicast-port)]
[request (make-search-request search-target mx user-agent)])
(dynamic-wind
void
(lambda ()
(define started-at (current-inexact-milliseconds))
(udp-bind! socket interface 0)
(dbg-upnp-ssdp "SSDP socket bound to interface ~a" (or interface "default"))
(udp-multicast-set-interface! socket interface)
(udp-multicast-set-ttl! socket ttl)
(for ([attempt (in-range repeat)])
(dbg-upnp-ssdp "Sending SSDP M-SEARCH attempt ~a of ~a" (add1 attempt) repeat)
(udp-send-to socket
ssdp-multicast-address
ssdp-multicast-port
request)
(when (< attempt (sub1 repeat))
(sleep 0.1)))
(receive-responses socket effective-timeout))
(sleep 0.25)))
(receive-responses socket effective-timeout started-at))
(lambda ()
(dbg-upnp-ssdp "Closing SSDP socket")
(udp-close socket))))))