[plt-scheme] web server directories

Pedro Pinto writes:
 > I am moving a web site from IIS on Windows to the PLT web server on 
 > FreeBSD. My web-site includes a set of directories which users should be 
 > able to browse. With IIS I had to set a configuration parameter to 
 > instruct it to generate web-pages containing file-lists for each of the 
 > browsable directories.
 > 
 > Is there a simple way to do this using PLT? Or perhaps I need to write 
 > some servlets?

I couldn't find any way, so I kludged up the following little servlet,
index.scm.  Use the URL http://your-host/servlets/index.scm?d=path
where path is relative to the htdocs directory.  For access control,
it simply checks for the presence of a file called ".htaccess" in the
directory or any parent directory; you'll probably want to do
something a little less braindead.  It could probably also benefit
from send/suspend/dispatch that was discussed here recently to
abstract away all the query strings, but I haven't had time to look
into that.  I'd also appreciate any other style comments...

--dougo at place.org


(require (lib "unitsig.ss")
         (lib "servlet-sig.ss" "web-server")
	 (lib "servlet-helpers.ss" "web-server")
	 (lib "util.ss" "web-server")
	 (lib "url.ss" "net")
	 (lib "xml.ss" "xml")
	 (rename (lib "list.ss") quicksort quicksort)
	 (lib "date.ss")
	 (lib "match.ss")
	 (lib "1.ss" "srfi")
	 (lib "13.ss" "srfi"))

;;; TODO: parent directory, column sorting

(unit/sig () (import servlet^)

  (report-errors-to-browser send/back)

  (define *web-root* "..")
  (define *htdocs* (build-path *web-root* "htdocs"))

  (define *footer*
    `(address "Powered by " (a ((href "http://www.plt-scheme.org/")) "PLT")))

  (define (error-response code name message)
    (make-response/full code name (current-seconds) "text/html" '()
			(list (xexpr->string
			       `(html
				 (head (title ,name))
				 (body (p ,message) ,*footer*))))))

  (define (forbidden-response)
    (error-response
     403 "Forbidden"
     "You don't have permission to access that directory on this server."))

  (define (not-found-response)
    (error-response
     404 "Not Found"
     "The file you were looking for was not found on this server."))
    

  (define (access-allowed? root path)
    (and (string? path)
	 (not (string=? root path))
	 (or (file-exists? (build-path path ".htaccess"))
	     (access-allowed?
	      root
	      (let-values (((base name must-be-dir?) (split-path path)))
		base)))))

  (define *months* #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
		     "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

  (define (month->string month)
    (vector-ref *months* (sub1 month)))

  (define (add-zero n)
    (if (< n 10)
	(string-append "0" (number->string n))
	n))

  (define (last-modified path)
    (match-let ((($ date second minute hour day month year
		    week-day year-day dst? time-zone-offset)
		 (seconds->date (file-or-directory-modify-seconds path))))
      (format "~a-~a-~a ~a:~a"
	      (add-zero day) (month->string month) year
	      (add-zero hour) (add-zero minute))))


  (define (directory-xexprs url-path env)
    (let ((dir-path (url-path->path *htdocs* url-path)))
      (unless (directory-exists? dir-path)
	(send/finish (not-found-response)))
      (unless (and (relative-path? url-path)
		   (access-allowed? *htdocs* dir-path))
	(send/finish (forbidden-response)))
      (map
       (lambda (path)
	 (let* ((file-path (build-path dir-path path))
		(path (if (directory-exists? file-path)
			  (string-append path "/")
			  path))
		(url-path (if (directory-exists? file-path)
			      (string-append "?d=" url-path path)
			      (string-append "/" url-path path)))
		(size (if (file-exists? file-path)
			  (string-append
			   (number->string
			    (ceiling (/ (file-size file-path) 1024)))
			   "k")
			  "-")))	   
	   `(tr (td (pre (a ((href ,url-path)) ,path) "        "))
		(td (pre ,(last-modified file-path) "  "))
		(td ((align "right")) (pre ,size)))))
       (quicksort (remove (lambda (s) (string-prefix? "." s))
			  (directory-list dir-path))
		  string<?))))

  (let* ((env (request-bindings initial-request))
	 (dir (extract-binding/single 'd env))
	 (dir (if (string-suffix? "/" dir)
		  dir
		  (string-append dir "/")))
	 (index (directory-xexprs dir env)))
    `(html
      (head (title ,dir))
      (body
       (h1 "Index of /" ,dir)
       (hr)
       (table (tr ((align "left"))
		  (th (pre "Name        "))
		  (th (pre "Last Modified    "))
		  (th ((align "right")) (pre "Size")))
	      , at index)
       (hr)
       ,*footer*
       ))
    ))