diff --git a/info.rkt b/info.rkt index f4e4b06..5ee0c1c 100644 --- a/info.rkt +++ b/info.rkt @@ -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"))) diff --git a/media-file-server.rkt b/media-file-server.rkt index ad99cc3..c1a6816 100644 --- a/media-file-server.rkt +++ b/media-file-server.rkt @@ -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))) diff --git a/query.rkt b/query.rkt index 80fcfca..6e271c9 100644 --- a/query.rkt +++ b/query.rkt @@ -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) "") (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 diff --git a/scribblings/main.scrbl b/scribblings/main.scrbl index b939528..ead2aee 100644 --- a/scribblings/main.scrbl +++ b/scribblings/main.scrbl @@ -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?))]{ diff --git a/service.rkt b/service.rkt index 0ab4de0..9d30191 100644 --- a/service.rkt +++ b/service.rkt @@ -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))] diff --git a/ssdp.rkt b/ssdp.rkt index 3d803b2..821a83f 100644 --- a/ssdp.rkt +++ b/ssdp.rkt @@ -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))))))