; Copyright (C) 2009 Amit Saha ; This program is free software; you can redistribute it and/or modify it under ; the terms of the GNU General Public License as published by the Free Software ; Foundation; either version 3 of the License, or (at your option) any later version. ; This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; ; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ; PURPOSE. See the GNU General Public License for more details. ; You should have received a copy of the GNU General Public License along with ; this program; if not, write to the Free Software Foundation, Inc., 59 Temple ; Place, Suite 330, Boston, MA 02111-1307 USA ; ; Please contact for bug reports/patches or anything else via electronic mail: ; Amit Saha , http://amitksaha.wordpress.com ; ; About: ; Learn Scheme programming and SimpleHTTPServer.py are the two inspirations ; for the current work. This program serves fles over HTTP and is coded in ; the Scheme language using plt-scheme. It starts a HTTP Server with the ; current working directory as the starting directory. You can navigate/copy/view ; files over HTTP ; Version History: ; 27-JULY-2009- Version 0.8. Confirmed to work *only* on Ubuntu Linux and ; with plt-scheme only. Blog post: http://amitksaha.wordpress.com/?p=119 ; Acknowledgements: ; Folks on the plt-scheme users mailing list, especially Jay McCarthy, ; Noel Walsh and folks on Bangalore FP users group : ; (http://groups.google.co.in/group/bangalore-fp) ; Usage: ; $ mzscheme ; Welcome to MzScheme v4.1.3 [3m], Copyright (c) 2004-2008 PLT Scheme Inc. ; > (enter! "fileserveHTTP.ss") ; > (serve 8080) ; you can also specify some other port.. ; # ; The server is now started. Open :8080/ from your browser #lang scheme (require xml net/url) (require web-server/private/mime-types) (require net/uri-codec) ;; serve : Integer -> (-> Void) (define (serve port-no) (define listener (tcp-listen port-no 5 #t)) (define (loop) (accept-and-handle listener) (loop)) (define t (thread loop)) (lambda () (kill-thread t) (tcp-close listener))) ;; accept-and-handle : Integer -> (-> Void) (define (accept-and-handle listener) (define-values (in out) (tcp-accept listener)) (thread (lambda() (handle in out) (close-input-port in) (close-output-port out)))) ;; handle : InputPort OutputPort -> (Void) (define (handle in out) (define req ;Match the first line get the GET request: (regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+" (read-line in))) (when req ; discard the request header (up to blank line): (regexp-match #rx"(\r\n|^)\r\n" in) ; Send the file ; (list-ref req 1) => "/filename" ; if filename = '/' its basically the "index" or the ; homepage request ;else ; we need to open the file/directory and send it.. ;(define filename-len (string-length (list-ref req 1)))- read up ;on this- why can't we use this? ; (let ([filename-len (string-length (list-ref req 1))]) (display req) (if (= filename-len 1) (doGet-list out) (doGet-file (uri-decode (list-ref req 1)) out)) ;;uri-decode takes care of the URI encodings ))) ;; doGet-list : OutputPort -> (Text in the OutputPort) (define (doGet-list out) (display "HTTP/1.0 200 OK\r\nContent-Type: text/html\r\nServer: plt-schemeFileBrowser\r\n\r\n" out) (display "

File Browser over HTTP

" out) ; send back the list of files/directories obtained from (directory-list (current-directory)) ; Iterate over the 'list' of file paths returned. ; (for/list ([file (directory-list (current-directory))]) (display "

" out) (display file out) (cond [(directory-exists? file) (display "/" out)]) (display "

" out) ) (display "" out) ) ;; doGet-file : OutputPort -> (Text in the OutputPort) (define (doGet-file filename out) ;; if its a file, open and read, then write its contents ;; if its a directory, send the directory listings, like above. ;; ;; strip the prefix "/" from file name (set! filename (substring filename 1 (string-length filename))) (if (directory-exists? filename) ;; ToDo: @check if there is a better way to do this (begin ;; if its a directory, then append a "/" if not done already... (display "HTTP/1.0 200 OK \r\nContent-Type: text/html \r\nServer: plt-schemeFileBrowser\r\n\r\n" out) (display "

File browser over HTTP

" out) (display "Listing current directory:" out) (display (string->path filename) out) (for/list ([file (directory-list (string->path filename))]) (display file) (display "\n") (display "

path filename) file)) (display "/" out)]) (display "\">" out) (display file out) (cond [(directory-exists? (build-path (string->path filename) file)) (display "/" out)]) (display "

" out) ) (display "" out)) ;; else: ;; opening the file and sending the contents. (begin (display "HTTP/1.0 200 OK\r\n" out) (display "Content-Type: " out) ;; the next line guesses the MIME type of the file by consulting the system's ;; mime.types file. Right now, this code is guranteed to work only on Ubuntu Linux ;; Other Linux-es might work too (display ((make-path->mime-type "/etc/mime.types") (string->path filename)) out) (display "\r\nContent-length: " out) (display (file-size filename) out) (display "\r\nServer:plt-schemeFileBrowser\r\n\r\n" out) (display "

" out) (with-input-from-file (string->path filename) (lambda () (display (read-bytes (file-size filename)) out)) #:mode 'binary) )) )