stable http transfer

media-file-server.rkt

@@ -207,10 +207,17 @@
                 #"text/plain; charset=utf-8"
                 '()
                 (list #"Not found\n"))))]
+           [dispatch-files (sequence:make file-dispatcher not-found-dispatcher)]
            [dispatcher
-            (sequence:make
-             file-dispatcher
-             not-found-dispatcher)]
+            (lambda (connection request)
+              (let* ([path (url-path-string (request-uri request))]
+                     [file (call-with-semaphore lock
+                             (lambda () (hash-ref publications path #f)))])
+                (if file
+                    (log-media-transfer
+                     request file
+                     (lambda () (dispatch-files connection request)))
+                    (not-found-dispatcher connection request))))]
            [confirmation (make-async-channel)]
            [stop
             (serve
@@ -234,6 +241,24 @@
        #f))))
 
 
+;;; Logs each published GET/HEAD request around the complete file dispatch.
+;;; No publication lock is held while the renderer reads its response.
+(define (log-media-transfer request file send!)
+  (let* ([started (current-inexact-monotonic-milliseconds)]
+         [completed? #f]
+         [range (headers-assq* #"Range" (request-headers/raw request))]
+         [client (request-client-ip request)]
+         [method (bytes->string/utf-8 (request-method request))])
+    (dynamic-wind
+      (lambda ()
+        (info-upnp-file-server "Media transfer started: client=~a method=~a file=~a range=~a"
+                               client method file (if range (header-value range) "full")))
+      (lambda () (send!) (set! completed? #t))
+      (lambda ()
+        (info-upnp-file-server "Media transfer ~a: client=~a method=~a file=~a elapsed-ms=~a"
+                               (if completed? "sent" "interrupted") client method file
+                               (round (- (current-inexact-monotonic-milliseconds) started)))))))
+
 (define (dlna-response-headers _path)
   (list
    (header #"Accept-Ranges" #"bytes")