Moving network-error

svn: r671
This commit is contained in:
Jay McCarthy 2005-08-25 14:53:21 +00:00
parent 93988a2551
commit 1fb9d886e4
3 changed files with 16 additions and 12 deletions

View File

@ -36,14 +36,7 @@
[read-bindings (connection? symbol? url? (listof header?)
. -> . (union (listof binding?) string?))])
;; network-error: symbol string . values -> void
;; throws a formatted exn:fail:network
(define (network-error src fmt . args)
(raise (make-exn:fail:network
(string->immutable-string
(apply format (format "~a: ~a" src fmt) args))
(current-continuation-marks))))
;; **************************************************
;; read-request: input-port -> request boolean?
;; read the request line, and the headers, determine if the connection should

View File

@ -5,7 +5,8 @@
(lib "pretty.ss")
(lib "xml.ss" "xml")
(lib "string.ss" "srfi" "13")
"connection-manager.ss")
"connection-manager.ss"
"util.ss")
;; **************************************************
;; DATA DEF for response
@ -251,8 +252,9 @@
(when (eq? method 'get)
; Give it one second per byte.
(adjust-connection-timeout! conn (file-size file-path))
(call-with-input-file file-path
(lambda (i-port) (copy-port i-port (connection-o-port conn))))))
(with-handlers ([void (lambda (e) (network-error 'output-file (exn-message e)))])
(call-with-input-file file-path
(lambda (i-port) (copy-port i-port (connection-o-port conn)))))))
;; **************************************************
;; output-response/method: connection response/full symbol -> void

View File

@ -8,7 +8,8 @@
(provide provide-define-struct
extract-flag
translate-escapes
hash-table-empty?)
hash-table-empty?
network-error)
(provide/contract
[path->list (path? . -> . (cons/c (union path? (symbols 'up 'same))
@ -20,6 +21,14 @@
[get-mime-type (path? . -> . bytes?)]
[build-path-unless-absolute (path? (union string? path?) . -> . path?)])
;; network-error: symbol string . values -> void
;; throws a formatted exn:fail:network
(define (network-error src fmt . args)
(raise (make-exn:fail:network
(string->immutable-string
(apply format (format "~a: ~a" src fmt) args))
(current-continuation-marks))))
;; build-path-unless-absolute : path (union string? path?) -> path?
(define (build-path-unless-absolute base path)
(if (absolute-path? path)