569 lines
		
	
	
		
			19 KiB
		
	
	
	
		
			Scheme
		
	
	
	
			
		
		
	
	
			569 lines
		
	
	
		
			19 KiB
		
	
	
	
		
			Scheme
		
	
	
	
| ;; Request-handlers for scheme web server
 | |
| 
 | |
| ;; general request-handler-combinator:
 | |
| ;; predicate: path x request --> boolean
 | |
| ;; if #t, handler is called
 | |
| ;; if #f, default-handler is called
 | |
| (define (make-request-handler predicate handler default-handler)
 | |
|   (lambda (path req)
 | |
|     (if (predicate path req)
 | |
| 	(handler path req)
 | |
| 	(default-handler path req))))
 | |
| 
 | |
| ;; same as make-request-handler except that the predicate is only
 | |
| ;; called with the path:
 | |
| ;; predicate: path --> boolean
 | |
| (define (make-path-handler predicate handler default-handler)
 | |
|   (make-request-handler
 | |
|    (lambda (path req) (predicate path)) handler default-handler))
 | |
| 
 | |
| ;; selects handler according to host-field of http-request
 | |
| (define (make-hostname-handler hostname handler default-handler)
 | |
|     (make-request-handler 
 | |
|      (lambda (path req)
 | |
|        ;; we expect only one host-header-field
 | |
|        (string=? hostname (string-trim (get-header (request:headers req) 'host))))
 | |
|      handler default-handler))
 | |
| 
 | |
| ;; selects handler according to path-prefix
 | |
| ;; if path-prefix matches, handler is called without the path-prefix
 | |
| (define (make-path-prefix-handler path-prefix handler default-handler)
 | |
|   (lambda (path req)
 | |
|     (if (string=? path-prefix (car path))
 | |
| 	(handler (cdr path) req)
 | |
| 	(default-handler path req))))
 | |
| 
 | |
| (define server/buffer-size 8192)	; WTF
 | |
| 
 | |
| 
 | |
| ;;; (alist-path-dispatcher handler-alist default-handler) -> handler
 | |
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 | |
| ;;; This function creates a table-driven path-handler that dispatches off
 | |
| ;;; of the car of the request path. The handler uses the car to index into
 | |
| ;;; a path-handler alist. If it finds a hit, it recurses using the table's
 | |
| ;;; path-handler. If no hits, it handles the path with a default handler.
 | |
| ;;; An alist handler is passed the tail of the original path; the
 | |
| ;;; default handler gets the entire original path.
 | |
| ;;;
 | |
| ;;; This procedure is how you say: "If the first element of the URL's
 | |
| ;;; path is 'foo', do X; if it's 'bar', do Y; otherwise, do Z." 
 | |
| 
 | |
| (define (alist-path-dispatcher handler-alist default-handler)
 | |
|   (fold-right 
 | |
|    (lambda (handler-pair default-handler)
 | |
|      (make-path-prefix-handler
 | |
|       (car handler-pair)
 | |
|       (cdr handler-pair)
 | |
|       default-handler))
 | |
|    default-handler
 | |
|    handler-alist))
 | |
| 
 | |
| ;;; (home-dir-handler user-public-dir) -> handler
 | |
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 | |
| ;;; Return a path handler that looks things up in a specific directory
 | |
| ;;; in the user's home directory. If ph = (home-dir-handler "public_html")
 | |
| ;;; then ph is a path-handler that serves files out of peoples' public_html
 | |
| ;;; subdirectory. So
 | |
| ;;;	(ph '("shivers" "hk.html") req)
 | |
| ;;; will serve the file 
 | |
| ;;;     ~shivers/public_html/hk.html
 | |
| ;;; The path handler treats the URL path as (<user> . <file-path>),
 | |
| ;;; serving
 | |
| ;;;     ~<user>/<user-public-dir>/<file-path>
 | |
| 
 | |
| (define (home-dir-handler user-public-dir)
 | |
|   (lambda (path req)		
 | |
|     (if (pair? path)
 | |
| 	(serve-rooted-file-path (string-append (http-homedir (car path) req)
 | |
| 					       "/"
 | |
| 					       user-public-dir)
 | |
| 				(cdr path)
 | |
| 				file-serve
 | |
| 				req)
 | |
| 	(http-error http-reply/bad-request req
 | |
| 		    "Path contains no home directory."))))
 | |
| 
 | |
| ;;; (tilde-home-dir-handler-predicate path)
 | |
| ;;; (tilde-home-dir-handler user-public-dir)
 | |
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 | |
| ;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"),
 | |
| ;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
 | |
| ;;; default handler.
 | |
| 
 | |
| (define (tilde-home-dir-handler-predicate path)
 | |
|   (lambda (path)
 | |
|     (and (pair? path)			; Is it a ~foo/...
 | |
| 	 (let ((head (car path)))	; home-directory path?
 | |
| 	   (and (> (string-length head) 0)
 | |
| 		(char=? (string-ref head 0) #\~))))))
 | |
| 
 | |
| (define (tilde-home-dir-handler user-public-dir)
 | |
|   (lambda (path req)
 | |
|     (let* ((tilde-home (car path))	; Yes.
 | |
| 	   (slen (string-length tilde-home))
 | |
| 	   (subdir (string-append
 | |
| 		    (http-homedir (substring tilde-home 1 slen) req)
 | |
| 		    "/"
 | |
| 		    user-public-dir)))
 | |
|       (serve-rooted-file-path subdir (cdr path) file-serve req))))
 | |
| 
 | |
| 
 | |
| ;;; Make a handler that serves files relative to a particular root
 | |
| ;;; in the file system. You may follow symlinks, but you can't back up
 | |
| ;;; past ROOT with ..'s.
 | |
| 
 | |
| (define (rooted-file-handler root)
 | |
|   (lambda (path req)
 | |
|     (serve-rooted-file-path root path file-serve req)))
 | |
| 
 | |
| ;;; Dito, but also serve directory indices for directories without
 | |
| ;;; index.html.  ICON-NAME specifies how to generate the links to
 | |
| ;;; various decorative icons for the listings.  It can either be a
 | |
| ;;; procedure which gets passed one of the icon tags in TAG->ICON and
 | |
| ;;; is expected to return a link pointing to the icon.  If it is a
 | |
| ;;; string, that is taken as prefix to which the names from TAG->ICON
 | |
| ;;; are appended.
 | |
| 
 | |
| (define (rooted-file-or-directory-handler root icon-name)
 | |
|   (let ((file-serve-and-dir (file-server-and-dir icon-name)))
 | |
|     (lambda (path req)
 | |
|       (serve-rooted-file-path root path file-serve-and-dir req))))
 | |
| 
 | |
| 
 | |
| ;;; The null path handler -- handles nothing, sends back an error reply.
 | |
| ;;; Can be useful as the default in table-driven path handlers.
 | |
| 
 | |
| (define (null-path-handler path req)
 | |
|   (http-error http-reply/not-found req))
 | |
| 
 | |
| 
 | |
| ;;;; Support procs for the path handlers
 | |
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 | |
| 
 | |
| 
 | |
| ;;; (SERVE-ROOTED-FILE-PATH root file-path req)
 | |
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 | |
| ;;; Do a request for a file. The file-name is determined by appending the
 | |
| ;;; the FILE-PATH list the string ROOT. E.g., if
 | |
| ;;;     ROOT = "/usr/shivers"	FILE-PATH = ("a" "b" "c" "foo.html")
 | |
| ;;; then we serve file
 | |
| ;;;     /usr/shivers/a/b/c/foo.html
 | |
| ;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
 | |
| ;;;   (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path 
 | |
| ;;;    sequences are processed away by the browser when the URI is converted
 | |
| ;;;    to an absolute URI before it is sent off to the server.)
 | |
| ;;; It is possible to sneak a .. past this kind of front-end resolving by
 | |
| ;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
 | |
| ;;; this, SERVE-ROOTED-FILE-PATH will catch it, and abort the transaction.
 | |
| ;;; So you cannot make the reference back up past ROOT. E.g., this is
 | |
| ;;; not allowed:
 | |
| ;;;     FILE-PATH = ("a" "../.." "c" "foo.html")
 | |
| ;;;
 | |
| ;;; Only GET and HEAD ops are provided. 
 | |
| ;;; The URL's <search> component must be #f.
 | |
| ;;; The file is served if the server has read or stat(2) access to it,
 | |
| ;;; respectively. If the server is run as root, this might be a problem.
 | |
| ;;;
 | |
| ;;; FILE-SERVE is a procedure which gets passed the file name, the
 | |
| ;;; path, and the HTTP request to serve the file propert after the
 | |
| ;;; security checks.  Look in ROOTED-FILE-HANDLER and
 | |
| ;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
 | |
| 
 | |
| (define (serve-rooted-file-path root file-path file-serve req)
 | |
|   (if (http-url:search (request:url req))
 | |
|       (http-error http-reply/bad-request req
 | |
| 		  "Indexed search not provided for this URL.")
 | |
| 
 | |
|       (cond ((dotdot-check root file-path) =>
 | |
| 	     (lambda (fname) (file-serve fname file-path req)))
 | |
| 	    (else
 | |
| 	     (http-error http-reply/bad-request req
 | |
| 			 "URL contains unresolvable ..'s.")))))
 | |
| 
 | |
| 
 | |
| ;; Just (file-info fname) with error handling.
 | |
| 
 | |
| (define (stat-carefully fname req)
 | |
|   (with-errno-handler 
 | |
|    ((errno packet)
 | |
|     ((errno/noent)
 | |
|      (http-error http-reply/not-found req))
 | |
|     ((errno/acces)
 | |
|      (http-error http-reply/forbidden req)))
 | |
|    (file-info fname #t)))
 | |
| 
 | |
| ;;; A basic file request handler -- ship the dude the file. No fancy path
 | |
| ;;; checking. That has presumably been taken care of. This handler only
 | |
| ;;; takes care of GET and HEAD methods.
 | |
| 
 | |
| (define (file-serve-or-dir fname file-path req directory-serve)
 | |
|   (if (file-name-directory? fname)	; Simple index generation.
 | |
|       (directory-serve fname file-path req)
 | |
|       
 | |
|       (let ((request-method (request:method req)))
 | |
| 	(cond
 | |
| 	 ((or (string=? request-method "GET")
 | |
| 	      (string=? request-method "HEAD"))			; Absolutely.
 | |
| 	  (let ((info  (stat-carefully fname req)))
 | |
| 	    (case (file-info:type info)
 | |
| 	      
 | |
| 	      ((regular fifo socket)
 | |
| 	       (send-file fname info req))
 | |
| 	      
 | |
| 	      ((directory)	; Send back a redirection "foo" -> "foo/"
 | |
| 	       (http-error http-reply/moved-perm req
 | |
| 			   (string-append (request:uri req) "/")
 | |
| 			   (string-append (http-url->string (request:url req))
 | |
| 					  "/")))
 | |
| 
 | |
| 	      (else (http-error http-reply/forbidden req)))))
 | |
| 	 
 | |
| 	 (else (http-error http-reply/method-not-allowed req))))))
 | |
| 
 | |
| (define (directory-index-serve fname file-path req)
 | |
|   (file-serve (string-append fname "index.html") file-path req))
 | |
| 
 | |
| (define (file-serve fname file-path req)
 | |
|   (file-serve-or-dir fname file-path req directory-index-serve))
 | |
| 
 | |
| (define (tag->alt tag)
 | |
|   (case tag
 | |
|     ((directory) "[DIR]")
 | |
|     ((text) "[TXT]")
 | |
|     ((doc) "[DOC]")
 | |
|     ((image) "[IMG]")
 | |
|     ((movie) "[MVI]")
 | |
|     ((audio) "[AU ]")
 | |
|     ((archive) "[TAR]")
 | |
|     ((compressed) "[ZIP]")
 | |
|     ((uu) "[UU ]")
 | |
|     ((binhex) "[HQX]")
 | |
|     ((binary) "[BIN]")
 | |
|     (else "[   ]")))
 | |
| 
 | |
| ;; These icons can, for example, be found in the cern-httpd-3.0
 | |
| ;; distribution at http://www.w3.org/pub/WWW/Daemon/
 | |
| 
 | |
| (define (tag->icon tag)
 | |
|   (case tag
 | |
|     ((directory) "directory.xbm")
 | |
|     ((text) "text.xbm")
 | |
|     ((doc) "doc.xbm")
 | |
|     ((image) "image.xbm")
 | |
|     ((movie) "movie.xbm")
 | |
|     ((audio) "sound.xbm")
 | |
|     ((archive) "tar.xbm")
 | |
|     ((compressed) "compressed.xbm")
 | |
|     ((uu) "uu.xbm")
 | |
|     ((binhex) "binhex.xbm")
 | |
|     ((binary) "binary.xbm")
 | |
|     ((blank) "blank.xbm")
 | |
|     ((back) "back.xbm")
 | |
|     (else "unknown.xbm")))
 | |
|  
 | |
| (define (file-extension->tag fname)
 | |
|   (let ((ext (file-name-extension fname)))
 | |
|     (cond 
 | |
|      ((string-ci=? ext ".txt") 'text)
 | |
|      ((or (string-ci=? ext ".doc")
 | |
| 	  (string-ci=? ext ".html")
 | |
| 	  (string-ci=? ext ".rtf")
 | |
| 	  (string-ci=? ext ".tex")) 'doc)
 | |
|      ((or (string-ci=? ext ".gif")
 | |
| 	  (string-ci=? ext ".jpg")
 | |
| 	  (string-ci=? ext ".jpeg")
 | |
| 	  (string-ci=? ext ".tiff")
 | |
| 	  (string-ci=? ext ".tif")) 'image)
 | |
|      ((or (string-ci=? ext ".mpeg")
 | |
| 	  (string-ci=? ext ".mpg")) 'movie)
 | |
|      ((or (string-ci=? ext ".au")
 | |
| 	  (string-ci=? ext ".snd")
 | |
| 	  (string-ci=? ext ".wav")) 'audio)
 | |
|      ((or (string-ci=? ext ".tar")
 | |
| 	  (string-ci=? ext ".zip")
 | |
| 	  (string-ci=? ext ".zoo")) 'archive)
 | |
|      ((or (string-ci=? ext ".gz")
 | |
| 	  (string-ci=? ext ".Z")
 | |
| 	  (string-ci=? ext ".z")) 'compressed)
 | |
|      ((string-ci=? ext ".uu") 'uu)
 | |
|      ((string-ci=? ext ".hqx") 'binhex)
 | |
|      (else 'binary))))
 | |
| 
 | |
| (define (file-tag fname type)
 | |
|   (case type
 | |
|     ((regular fifo socket) (file-extension->tag fname))
 | |
|     ((directory) 'directory)
 | |
|     (else 'unknown)))
 | |
| 
 | |
| (define (time->directory-index-date-string time)
 | |
|   (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
 | |
| 
 | |
| (define (read-max-lines fname max)
 | |
|   (call-with-input-file
 | |
|       fname
 | |
|     (lambda (port)
 | |
|       (let loop ((r "") (i max))
 | |
| 	(if (zero? i)
 | |
| 	    r
 | |
| 	    (let ((line (read-line port)))
 | |
| 	      (if (eof-object? line)
 | |
| 		  r
 | |
| 		  (loop (string-append r " " line) (- i 1)))))))))
 | |
| 
 | |
| (define (string-cut s n)
 | |
|   (if (>= (string-length s) n)
 | |
|       (substring s 0 n)
 | |
|       s))
 | |
| 
 | |
| (define html-file-header
 | |
|   (let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
 | |
| 	(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
 | |
|     (lambda (fname n)
 | |
|       (let ((stuff (read-max-lines fname 10)))
 | |
| 	(cond
 | |
| 	 ((regexp-exec title-tag-regexp stuff)
 | |
| 	  => (lambda (open-match)
 | |
| 	       (cond
 | |
| 		((regexp-exec title-close-tag-regexp stuff
 | |
| 			      (match:end open-match 0))
 | |
| 		 => (lambda (close-match)
 | |
| 		      (string-cut (substring stuff
 | |
| 					     (match:end open-match 0)
 | |
| 					     (match:start close-match 0))
 | |
| 				  n)))
 | |
| 		(else (string-cut (substring stuff
 | |
| 					     (match:end open-match 0)
 | |
| 					     (string-length stuff))
 | |
| 				  n)))))
 | |
| 	 (else ""))))))
 | |
| 
 | |
| (define (file-documentation fname n)
 | |
|   (cond
 | |
|    ((file-extension->content-type fname)
 | |
|     => (lambda (content-type)
 | |
| 	 (if (and (string=? content-type "text/html" )
 | |
| 		  (file-readable? fname))
 | |
| 	     (html-file-header fname n)
 | |
| 	     "")))
 | |
|    (else "")))
 | |
| 
 | |
| (define (directory-index req dir icon-name)
 | |
|   
 | |
|   (define (pad-file-name file)
 | |
|     (write-string (make-string (- 21 (string-length file))
 | |
| 			       #\space)))
 | |
|   
 | |
|   (define (emit-file-name file)
 | |
|     (let ((l (string-length file)))
 | |
|       (if (<= l 20)
 | |
| 	  (emit-text file)
 | |
| 	  (emit-text (substring file 0 20)))))
 | |
|   
 | |
|   (define (index-entry file)
 | |
|     (let* ((fname (directory-as-file-name (string-append dir file)))
 | |
| 	   (info (stat-carefully fname req))
 | |
| 	   (type (file-info:type info))
 | |
| 	   (size (file-info:size info))
 | |
| 	   (tag (file-tag file type)))
 | |
|       (emit-tag #t 'img
 | |
| 		(cons 'src (icon-name tag))
 | |
| 		(cons 'alt (tag->alt tag)))
 | |
|       (with-tag #t a ((href file))
 | |
| 	(emit-file-name file))
 | |
|       (pad-file-name file)
 | |
|       (emit-text (time->directory-index-date-string (file-info:mtime info)))
 | |
|       (if size
 | |
| 	  (let* ((size-string
 | |
| 		  (string-append (number->string (quotient size 1024))
 | |
| 				 "K"))
 | |
| 		 (size-string
 | |
| 		  (if (<= (string-length size-string) 7)
 | |
| 		      size-string
 | |
| 		      (string-append (number->string (quotient size (* 1024 1024)))
 | |
| 				     "M")))
 | |
| 		 (size-string
 | |
| 		  (if (<= (string-length size-string) 8)
 | |
| 		      (string-append
 | |
| 		       (make-string (- 8 (string-length size-string)) #\space)
 | |
| 		       size-string)
 | |
| 		      size-string)))
 | |
| 	    (write-string size-string))
 | |
| 	  (write-string (make-string 8 #\space)))
 | |
|       (write-char #\space)
 | |
|       (emit-text (file-documentation fname 24))
 | |
|       (newline)))
 | |
| 
 | |
|   (let ((files (with-errno-handler
 | |
| 		((errno packet)
 | |
| 		 ((errno/acces)
 | |
| 		  (http-error http-reply/forbidden req)))
 | |
| 		(directory-files dir))))
 | |
|     (for-each index-entry files)
 | |
|     (length files)))
 | |
| 
 | |
| (define (directory-server icon-name)
 | |
|   (let ((icon-name
 | |
| 	 (cond
 | |
| 	  ((procedure? icon-name) icon-name)
 | |
| 	  ((string? icon-name)
 | |
| 	   (lambda (tag)
 | |
| 	     (string-append icon-name (tag->icon tag))))
 | |
| 	  (else tag->icon))))
 | |
|     (lambda (fname file-path req)
 | |
|       (let ((request-method (request:method req)))
 | |
| 	(cond
 | |
| 	 ((or (string=? request-method "GET")
 | |
| 	      (string=? request-method "HEAD"))
 | |
| 	  
 | |
| 	  (if (not (eq? 'directory 
 | |
| 			(file-info:type (stat-carefully fname req))))
 | |
| 	      (http-error http-reply/forbidden req))
 | |
| 	  
 | |
| 	  (if (not (v0.9-request? req))
 | |
| 	      (begin
 | |
| 		(begin-http-header #t http-reply/ok)
 | |
| 		(write-string "Content-type: text/html\r\n")
 | |
| 		(write-string "\r\n")))
 | |
| 
 | |
| 	  (with-tag #t html ()
 | |
|  	    (let ((title (string-append "Index of /"
 | |
| 					(string-join file-path "/"))))
 | |
| 	      (with-tag #t head ()
 | |
| 			(emit-title #t title))
 | |
| 	      (with-tag #t body ()
 | |
| 			(emit-header #t 1 title)
 | |
| 			(with-tag #t pre ()
 | |
| 				  (emit-tag #t 'img
 | |
| 					    (cons 'src (icon-name 'blank))
 | |
| 					    (cons 'alt "     "))
 | |
| 				  (write-string "Name                 ")
 | |
| 				  (write-string "Last modified          ")
 | |
| 				  (write-string "Size   ")
 | |
| 				  (write-string "Description")
 | |
| 				  (emit-tag #t 'hr)
 | |
| 				  (emit-tag #t 'img
 | |
| 					    (cons 'src (icon-name 'back))
 | |
| 					    (cons 'alt "[UP ]"))
 | |
| 		 (if (not (null? file-path))
 | |
| 		     (begin
 | |
| 		       (with-tag #t a ((href ".."))
 | |
| 				 (write-string "Parent directory"))
 | |
| 		       (newline)))
 | |
| 		 (let ((n-files (directory-index req fname icon-name)))
 | |
| 		   (emit-tag #t 'hr)
 | |
| 		   (format #t "~d files" n-files)))))))
 | |
| 	(else (http-error http-reply/method-not-allowed req)))))))
 | |
| 
 | |
| (define (index-or-directory-server icon-name)
 | |
|   (let ((directory-serve (directory-server icon-name)))
 | |
|     (lambda (fname file-path req)
 | |
|       (let ((index-fname (string-append fname "index.html")))
 | |
| 	
 | |
| 	(if (file-readable? index-fname)
 | |
| 	    (file-serve index-fname file-path req)
 | |
| 	    (directory-serve fname file-path req))))))
 | |
|   
 | |
| (define (file-server-and-dir icon-name)
 | |
|   (let ((index-or-directory-serve (index-or-directory-server icon-name)))
 | |
|     (lambda (fname file-path req)
 | |
|       (file-serve-or-dir fname file-path req index-or-directory-serve))))
 | |
| 
 | |
| ;;; Look up user's home directory, generating an HTTP error reply if you lose.
 | |
| 
 | |
| (define (http-homedir username req)
 | |
|   (with-fatal-error-handler (lambda (c decline)
 | |
| 			      (apply http-error http-reply/bad-request req
 | |
| 				     "Couldn't find user's home directory."
 | |
| 				     (condition-stuff c)))
 | |
| 
 | |
|     (home-dir username)))
 | |
| 
 | |
| 
 | |
| (define (send-file filename info req)
 | |
|   (with-errno-handler ((errno packet)
 | |
| 		       ((errno/acces)
 | |
| 			(http-error http-reply/forbidden req))
 | |
| 		       ((errno/noent)
 | |
| 			(http-error http-reply/not-found req)))
 | |
|     (call-with-input-file filename
 | |
|       (lambda (in)
 | |
| 	(let ((out (current-output-port)))
 | |
| 	  (if (not (v0.9-request? req))
 | |
| 	      (begin
 | |
| 		(begin-http-header out http-reply/ok)
 | |
| 		(receive (filename content-encoding)
 | |
| 			 (file-extension->content-encoding filename)
 | |
| 			 (if content-encoding
 | |
| 			     (format out "Content-encoding: ~A\r~%" 
 | |
| 				     content-encoding))
 | |
| 			 (cond ((file-extension->content-type filename) =>
 | |
| 				(lambda (ct) 
 | |
| 				  (format out "Content-type: ~A\r~%" ct)))))
 | |
| 		(format out "Last-modified: ~A\r~%"
 | |
| 			(time->http-date-string (file-info:mtime info)))
 | |
| 		(format out "Content-length: ~D\r~%" (file-info:size info))
 | |
| 		(write-string "\r\n" out)))
 | |
| 	  (copy-inport->outport in out))))))
 | |
| 
 | |
| 
 | |
| ;;; 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
 | |
|      ((string-ci=? ext ".html")		"text/html")
 | |
|      ((string-ci=? ext ".txt")       	"text/plain")
 | |
|      ((string-ci=? ext ".gif")		"image/gif")
 | |
|      ((string-ci=? ext ".png")		"image/png")
 | |
|      ((or (string-ci=? ext ".jpg")
 | |
| 	  (string-ci=? ext ".jpeg"))	"image/jpeg")
 | |
|      ((or (string-ci=? ext ".tiff")
 | |
| 	  (string-ci=? ext ".tif"))	"image/tif")
 | |
|      ((string-ci=? ext ".rtf")		"text/rtf")
 | |
|      ((or (string-ci=? ext ".mpeg")
 | |
| 	  (string-ci=? ext ".mpg"))	"video/mpeg")
 | |
|      ((or (string-ci=? ext ".au")
 | |
| 	  (string-ci=? ext ".snd"))	"audio/basic")
 | |
|      ((string-ci=? ext ".wav")		"audio/x-wav")
 | |
|      ((string-ci=? ext ".dvi")		"application/x-dvi")
 | |
|      ((or (string-ci=? ext ".tex")
 | |
| 	  (string-ci=? ext ".latex"))	"application/latex")
 | |
|      ((string-ci=? ext ".zip")		"application/zip")
 | |
|      ((string-ci=? ext ".tar")		"application/tar")
 | |
|      ((string-ci=? ext ".ps") 		"application/postscript")
 | |
|      ((string-ci=? ext ".pdf")		"application/pdf")
 | |
|      (else               		"application/octet-stream"))))
 | |
| 
 | |
| (define (file-extension->content-encoding fname)
 | |
|   (cond
 | |
|    ((let ((ext (file-name-extension fname)))
 | |
|       (cond 
 | |
|        ((string-ci=? ext ".Z")           "x-compress")
 | |
|        ((string-ci=? ext ".gz")          "x-gzip")
 | |
|        (else #f)))
 | |
|     => (lambda (encoding)
 | |
| 	 (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))
 |