logging added.

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")))
 

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)))

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) "<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

@@ -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
+through that interface. Reverse DNS lookup is only attempted when @racket[dns?] is true.
-@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

@@ -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)
+        (let ([code (http-status-code status)]
-                response-headers
+              [response-body (read-response-body in)])
-                (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

@@ -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)
+                        (begin
-                        (loop (cons response responses)
+                          (when response
-                              (hash-set seen key #t)))))))))))
+                            (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)))
+              (sleep 0.25)))
-          (receive-responses socket effective-timeout))
+          (receive-responses socket effective-timeout started-at))
         (lambda ()
+          (dbg-upnp-ssdp "Closing SSDP socket")
           (udp-close socket))))))