partial

svn: r4280

collects/web-server/dispatchers/dispatch-files.ss

@@ -3,11 +3,15 @@
            (lib "xml.ss" "xml")
            (lib "kw.ss")
            (lib "list.ss")
+           (lib "plt-match.ss")
            (lib "contract.ss"))
+  (require (lib "pretty.ss"))         
   (require "dispatch.ss"
            "../configuration.ss"
            "../util.ss"
            "../mime-types.ss"
+           "../private/request.ss"
+           "../servlet-helpers.ss"
            "../response.ss")
   (provide/contract
    [interface-version dispatcher-interface-version?])
@@ -35,7 +39,25 @@
                         (translate-escapes (url-path->string (url-path uri)))))
       (cond
         [(file-exists? path)
-         (output-file conn path method (get-mime-type path))]
+         (match (headers-assq #"Range" (request-headers/raw req))
+           [#f
+            (output-file conn path method (get-mime-type path))]
+           [range
+            (match (bytes->string/utf-8 (header-value range))
+              [(regexp "^bytes=(.*)-(.*)$" (list s start end))
+               (define startn
+                 (if (string=? "" start)
+                     0
+                     (string->number start)))
+               (define endn
+                 (if (string=? "" end)
+                     +inf.0
+                     (string->number end)))               
+               (output-file/partial conn path method (get-mime-type path)
+                                    startn endn)]
+              [r
+               ; XXX: Unhandled range: r
+               (output-file conn path method (get-mime-type path))])])]
         [(directory-exists? path)
          (let loop ([dir-defaults indices])
            (cond

collects/web-server/response.ss

@@ -16,6 +16,8 @@
    [rename ext:output-response output-response (connection? any/c . -> . any)]
    [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . any)]
    [rename ext:output-file output-file (connection? path? symbol? bytes? . -> . any)]
+   ; XXX add contract
+   [rename ext:output-file/partial output-file/partial (connection? path? symbol? bytes? integer? integer? . -> . any)]
    [TEXT/HTML-MIME-TYPE bytes?])
   
   ;; Table 1. head responses:
@@ -199,9 +201,36 @@
         (call-with-input-file file-path
           (lambda (i-port) (copy-port i-port (connection-o-port conn)))))))
   
+  ;; **************************************************
+  ;; output-file/partial: connection path symbol bytes integer integer -> void
+  (define (output-file/partial conn file-path method mime-type
+                               start end-or-inf)
+    (define total-len (file-size file-path))
+    (define end (if (equal? +inf.0 end-or-inf)
+                    total-len
+                    end-or-inf))
+    (define len (- end start))
+    (output-headers conn 206 "Okay"
+                    `(("Content-Length: " ,len)
+                      ("Content-Range: " ,(format "bytes ~a-~a/~a" start end total-len)))
+                    (file-or-directory-modify-seconds file-path)
+                    mime-type)
+    (when (eq? method 'get)
+      ; Give it one second per byte.
+      (adjust-connection-timeout! conn len)
+      (with-handlers ([void (lambda (e) (network-error 'output-file/partial (exn-message e)))])
+        (call-with-input-file file-path
+          (lambda (i-port)
+            (define _ (file-position i-port start))
+            (define i-port/end (make-limited-input-port i-port end #t))
+            (copy-port i-port/end (connection-o-port conn)))))))
+  
   (define ext:output-file
     (ext:wrap output-file))
   
+  (define ext:output-file/partial    
+    (ext:wrap output-file/partial))
+  
   ;; **************************************************
   ;; output-response/method: connection response/full symbol -> void
   ;; If it is a head request output headers only, otherwise output as usual