commit 45: ee4f150542d3
parent 44: afbd15d04032
branch: default
tags: tip
NLTK Demo with a XML corpus
r0...@r00t-box
5 weeks ago
foobar-scripts / fileserveHTTP.ss
r45:ee4f150542d3 176 loc 6.1 KB embed / history / annotate / raw / 
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

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