* move dotdot-check and copy-inport->outport to sunet-utilities
* open necessary packages in various structures
This commit is contained in:
parent
d8c1e7f0ad
commit
755b715a77
|
@ -439,19 +439,6 @@
|
|||
(copy-inport->outport in port)))))))))
|
||||
|
||||
|
||||
;;; Assemble a filename from ROOT and the elts of PATH-LIST.
|
||||
;;; If the assembled filename contains a .. subdirectory, return #f,
|
||||
;;; otw return the filename.
|
||||
|
||||
(define dotdot-check
|
||||
(let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir.
|
||||
(lambda (root path-list)
|
||||
(let ((fname (if (null? path-list) root ; Bogus hack.
|
||||
(string-append (file-name-as-directory root)
|
||||
(string-join path-list "/")))))
|
||||
(and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir.
|
||||
fname)))))
|
||||
|
||||
(define (file-extension->content-type fname)
|
||||
(let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
|
@ -489,12 +476,3 @@
|
|||
(values (file-name-sans-extension fname) encoding)))
|
||||
(else (values fname #f))))
|
||||
|
||||
;;; Timeout on network writes?
|
||||
|
||||
(define (copy-inport->outport in out)
|
||||
(let ((buf (make-string server/buffer-size)))
|
||||
(let loop ()
|
||||
(cond ((read-string! buf in) => (lambda (nchars)
|
||||
(write-string buf out 0 nchars)
|
||||
(loop))))))
|
||||
(force-output out))
|
||||
|
|
|
@ -27,13 +27,6 @@
|
|||
(format-internet-host-address host-address))))))
|
||||
|
||||
|
||||
(define (dump fd)
|
||||
(let loop ((c (read-char fd)))
|
||||
(cond ((not (eof-object? c))
|
||||
(write-char c)
|
||||
(loop (read-char fd))))))
|
||||
|
||||
|
||||
(define (system-fqdn)
|
||||
(let ((host (host-info (system-name))))
|
||||
(let loop ((addresses (host-info:addresses host)))
|
||||
|
@ -41,3 +34,31 @@
|
|||
#f
|
||||
(or (dns-lookup-ip (car addresses))
|
||||
(loop (cdr addresses)))))))
|
||||
|
||||
;;; Assemble a filename from ROOT and the elts of PATH-LIST.
|
||||
;;; If the assembled filename contains a .. subdirectory, return #f,
|
||||
;;; otw return the filename.
|
||||
|
||||
(define dotdot-check
|
||||
(let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir.
|
||||
(lambda (root path-list)
|
||||
(let ((fname (if (null? path-list) root ; Bogus hack.
|
||||
(string-append (file-name-as-directory root)
|
||||
(string-join path-list "/")))))
|
||||
(and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir.
|
||||
fname)))))
|
||||
|
||||
;;; Timeout on network writes?
|
||||
|
||||
(define (copy-inport->outport in out . maybe-buffer-size)
|
||||
(let* ((buffer-size (:optional maybe-buffer-size 1024))
|
||||
(buf (make-string buffer-size)))
|
||||
(let loop ()
|
||||
(cond ((read-string! buf in) => (lambda (nchars)
|
||||
(write-string buf out 0 nchars)
|
||||
(loop)))))
|
||||
(force-output out)))
|
||||
|
||||
(define (dump fd)
|
||||
(copy-inport->outport fd (current-output-port)))
|
||||
|
||||
|
|
|
@ -237,7 +237,9 @@
|
|||
on-interrupt
|
||||
socket-address->string
|
||||
dump
|
||||
system-fqdn))
|
||||
system-fqdn
|
||||
copy-inport->outport
|
||||
dotdot-check))
|
||||
|
||||
(define-interface handle-fatal-error-interface
|
||||
(export with-fatal-error-handler*
|
||||
|
@ -638,6 +640,7 @@
|
|||
let-opt
|
||||
srfi-13
|
||||
dns
|
||||
let-opt ; :optional
|
||||
handle-fatal-error)
|
||||
(files (lib sunet-utilities)))
|
||||
|
||||
|
@ -755,6 +758,7 @@
|
|||
|
||||
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
||||
(open scheme scsh
|
||||
rfc822
|
||||
httpd-request ; REQUEST record type, v0.9-request
|
||||
srfi-1 ; FOLD-RIGHT
|
||||
srfi-13 ; STRING-TRIM
|
||||
|
@ -772,6 +776,7 @@
|
|||
htmlout
|
||||
crlf-io
|
||||
srfi-13 ; STRING-JOIN
|
||||
sunet-utilities ; dotdot-check, copy-inport->outport
|
||||
conditions
|
||||
handle-fatal-error
|
||||
)
|
||||
|
@ -838,6 +843,7 @@
|
|||
httpd-responses
|
||||
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
||||
httpd-error ; HTTP-ERROR
|
||||
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
|
||||
sunet-version
|
||||
scsh-utilities ; INDEX
|
||||
scsh ; syscalls
|
||||
|
|
Loading…
Reference in New Issue