[plt-scheme] Re: web server directories

Doug,

This looks exactly like what I was thinking of, thanks for sharing,
-pp


Doug Orleans wrote:

>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*
>       ))
>    ))
>
>  
>