1: ;*=====================================================================*/
  2: ;*    serrano/prgm/project/bigloo/fthread/examples/http/http.scm       */
  3: ;*    -------------------------------------------------------------    */
  4: ;*    Author      :  Manuel Serrano                                    */
  5: ;*    Creation    :  Mon Feb  4 14:28:58 2002                          */
  6: ;*    Last change :  Sat Oct 19 18:35:27 2002 (serrano)                */
  7: ;*    Copyright   :  2002 Manuel Serrano                               */
  8: ;*    -------------------------------------------------------------    */
  9: ;*    An HTTP server implemented with fair threads. This server        */
 10: ;*    accepts several concurent requests. It can serve HTML files or   */
 11: ;*    .scm files or .sh files.                                         */
 12: ;*=====================================================================*/
 13: 
 14: ;*---------------------------------------------------------------------*/
 15: ;*    The module                                                       */
 16: ;*---------------------------------------------------------------------*/
 17: (module fairthread-http
 18:    (library fthread)
 19:    (main main))
 20: 
 21: ;*---------------------------------------------------------------------*/
 22: ;*    Global parameters ...                                            */
 23: ;*---------------------------------------------------------------------*/
 24: (define *port-num* #f)
 25: (define *root-directory* (pwd))
 26: 
 27: ;*---------------------------------------------------------------------*/
 28: ;*    main ...                                                         */
 29: ;*---------------------------------------------------------------------*/
 30: (define (main args)
 31:    (args-parse (cdr args)
 32:       (("-h" "--help" (help "This help message"))
 33:        (args-parse-usage #f)
 34:        (exit 0))
 35:       (("-g" (help "Increase debug"))
 36:        (set! *thread-debug* (+fx 1 *thread-debug*)))
 37:       (("-p?port" (help "Port number"))
 38:        (set! *port-num* (string->integer port)))
 39:       (else
 40:        (set! *root-directory* else)))
 41:    (let* ((svr (make-socket-server))
 42:           (thd (make-thread (make-http-server svr) 'http-server))
 43:           (ts (thread-start! thd)))
 44:       (scheduler-start!)
 45:       (fprint (current-error-port) "Shuting down http server...")
 46:       (socket-shutdown svr)))
 47: 
 48: ;*---------------------------------------------------------------------*/
 49: ;*    make-socket-server ...                                           */
 50: ;*---------------------------------------------------------------------*/
 51: (define (make-socket-server)
 52:    (let ((s (if *port-num*
 53:                 (make-server-socket *port-num*)
 54:                 (make-server-socket))))
 55:       (print "Http server started: " (socket-port-number s))
 56:       s))
 57: 
 58: ;*---------------------------------------------------------------------*/
 59: ;*    make-http-server ...                                             */
 60: ;*---------------------------------------------------------------------*/
 61: (define (make-http-server s::socket)
 62:    (lambda ()
 63:       (let loop ((n 0))
 64:          (let ((s2 (socket-dup s)))
 65:             (thread-await! (make-connect-signal s2))
 66:             (thread-start! (make-thread (lambda () (http-eval s2 n))))
 67:             (thread-yield!)
 68:             (loop (+fx n 1))))))
 69: 
 70: ;*---------------------------------------------------------------------*/
 71: ;*    http-eval ...                                                    */
 72: ;*---------------------------------------------------------------------*/
 73: (define (http-eval s::socket num::int)
 74:    (define (readline)
 75:       (car (thread-await! (make-input-charset-signal
 76:                            (socket-input s)
 77:                            '(#\Newline #\Return)))))
 78:    (let* ((lines (let loop ((line (readline)))
 79:                     (thread-yield!)
 80:                     (if (=fx (string-length line) 1)
 81:                         '()
 82:                         (cons (substring line 0 (-fx (string-length line) 1))
 83:                               (loop (readline))))))
 84:           (line (car lines)))
 85:       (string-case line
 86:          ("VERSION"
 87:           (http-reply s "plain" "Web server V-1.0")
 88:           (socket-shutdown s #f))
 89:          ("v"
 90:           (http-reply s "plain" "Web server V-1.0")
 91:           (socket-shutdown s #f))
 92:          ("TEST"
 93:           (http-get "index.html" s)
 94:           (socket-shutdown s #f))
 95:          ((: "GET " (+ (out " \n\t\"")))
 96:           (http-get (the-substring 4 (the-length)) s)
 97:           (socket-shutdown s #f))
 98:          ((: "GET \"" (+ (out " \n\t\"")) "\"")
 99:           (http-get (the-substring 5 (-fx (the-length) 1)) s)
100:           (socket-shutdown s #f))
101:          (else
102:           (http-reply s "Unknown request -- \"" line "\"")
103:           (socket-shutdown s #f)))))
104:       
105: ;*---------------------------------------------------------------------*/
106: ;*    http-reply ...                                                   */
107: ;*---------------------------------------------------------------------*/
108: (define (http-reply socket::socket kind . str)
109:    (let ((p (socket-output socket)))
110:       (thread-await! (make-output-signal p "HTTP/1.0 200 Ok\r
111: Server: test_httpd/%x\r
112: Connection: close\r
113: Content-type: text/"))
114:       (thread-await! (make-output-signal p kind))
115:       (thread-await! (make-output-signal p "\r\n\r\n"))
116:       ;; display all the accumulated strings
117:       (for-each (lambda (s) (thread-await! (make-output-signal p s))) str)
118:       ;; mark the end of output
119:       (thread-await! (make-output-signal p "\r\n"))))
120: 
121: ;*---------------------------------------------------------------------*/
122: ;*    http-get ...                                                     */
123: ;*---------------------------------------------------------------------*/
124: (define (http-get file s::socket)
125:    (let* ((fname (if (char=? (string-ref file 0) (file-separator))
126:                      (string-append *root-directory* file)
127:                      file)))
128:       (case (string->symbol (suffix fname))
129:          ((scm)
130:           (http-get-scm fname s))
131:          ((sh)
132:           (http-get-sh fname s))
133:          (else
134:           (http-get-html fname s)))))
135: 
136: ;*---------------------------------------------------------------------*/
137: ;*    http-get-scm ...                                                 */
138: ;*---------------------------------------------------------------------*/
139: (define (http-get-scm file s::socket)
140:    (let ((proc (run-process "bigloo" "-i" "-s" file output: pipe:)))
141:       (http-get-input (process-output-port proc) s)))
142: 
143: ;*---------------------------------------------------------------------*/
144: ;*    http-get-sh ...                                                  */
145: ;*---------------------------------------------------------------------*/
146: (define (http-get-sh file s::socket)
147:    (let ((proc (run-process "sh" "-f" file output: pipe:)))
148:       (http-get-input (process-output-port proc) s)))
149: 
150: ;*---------------------------------------------------------------------*/
151: ;*    http-get-html ...                                                */
152: ;*---------------------------------------------------------------------*/
153: (define (http-get-html fname s::socket)
154:    (if (file-exists? fname)
155:        (let ((p (open-input-file fname)))
156:           (http-get-input p s)
157:           (close-input-port p))
158:        (http-reply s "plain" "Can't find file \"" fname "\"")))
159:       
160: ;*---------------------------------------------------------------------*/
161: ;*    http-get-input ...                                               */
162: ;*---------------------------------------------------------------------*/
163: (define (http-get-input p::input-port s::socket)
164:    (let loop ((res '())
165:               (num 0))
166:       (let ((v (thread-await! (make-input-len-signal p 1024))))
167:          (thread-yield!)
168:          (if (cdr v)
169:              (apply http-reply s "html" (reverse! (cons (car v) res)))
170:              (loop (cons (car v) res)
171:                    (+ num (string-length (car v))))))))