stable http transfer

service.rkt

@@ -13,6 +13,7 @@
          racket/port
          racket/string
          xml
+         "private/http-transfer.rkt"
          "private/model.rkt"
          "private/xml.rkt")
 
@@ -155,12 +156,15 @@
 
 (define (read-xml-url location)
   (dbg-upnp-soap "Reading UPnP XML description from ~a" location)
-  (call/input-url
-   (string->url location)
-   (lambda (url)
-     (get-pure-port url '() #:redirections 3))
-   (lambda (in)
-     (xml->xexpr (document-element (read-xml in))))))
+  (call-with-http-timeout
+   10
+   (λ (_progress!)
+     (call/input-url
+      (string->url location)
+      (λ (url)
+        (get-pure-port url '() #:redirections 3))
+      (λ (in)
+        (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))
@@ -298,18 +302,21 @@
                                "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)
-                                   #:ssl? ssl?
-                                   #:port port
-                                   #:method #"POST"
-                                   #:headers headers
-                                   #:data body)])
-        (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))))))
+      (call-with-http-timeout
+       10
+       (λ (_progress!)
+         (let-values ([(status response-headers in)
+                       (http-sendrecv host
+                                      (url-request-target url-value)
+                                      #:ssl? ssl?
+                                      #:port port
+                                      #:method #"POST"
+                                      #:headers headers
+                                      #:data body)])
+           (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