Source

foobar-scripts / fileserveHTTP.ss

; 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 <amitsaha.in@gmail.com>, 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..
; #<procedure:...fileserveHTTP.ss:27:2>
; The server is now started. Open <your ip>: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 "<html><body><h1> File Browser over HTTP </h1> " 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 "<li><a href=\"" out)
	    (display file out)
	    (cond 
	     [(directory-exists? file) (display "/" out)])
	    (display "\">" out)
            (display file  out)
	    (cond 
	     [(directory-exists? file) (display "/" out)])

	    (display "</a></li>" out)
	    )
 
	 (display "</body></html>" 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 "<html><body><h1>File browser over HTTP</h1>" out)
      (display "Listing current directory:" out)
      (display (string->path filename) out)
        (for/list ([file (directory-list (string->path filename))])
	    (display file)
	    (display "\n")
	    (display "<li><a href=\"" out)
	    (display file out)
	    (cond 
	     [(directory-exists? (build-path (string->path filename) file)) (display "/" out)])
	    (display "\">" out)
            (display file  out)
	    (cond 
	     [(directory-exists? (build-path (string->path filename) file)) (display "/" out)])
	    (display "</a></li>" out)
	    )
	(display "</body></html>" 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 "<hr> </hr>" out)
	      (with-input-from-file (string->path filename)
				   (lambda ()
				     (display (read-bytes (file-size filename)) out)) #:mode 'binary)
	))
    
    )