Commits

Taylor Venable committed f022f7d

More complete code.

Comments (0)

Files changed (1)

 ;;; Last Change: $Date$
 ;;; Revision: $Revision$
 
-(module server
-  (export start stop)
+(define-module www.server
+  (export server-start          ; start the server
+          add-handler!          ; add a handler
+          server-newline)       ; write a \r\n newline
 
-  (define (start))
-  (define (stop)))
+  (use gauche.net)
+  (use srfi-1)
+
+  (define (dispatch sock)
+    (let* ((input (socket-input-port sock))
+           (output (socket-output-port sock))
+           (request (parse-request input output))
+           (headers (parse-headers input output))
+           (matches (filter (lambda (x)
+                              (rxmatch (second x) (second request)))
+                            (filter (lambda (x)
+                                      (string=? (first x) (first request)))
+                                    handlers))))
+      (display request)(newline)
+      (display headers)(newline)
+      (if (null? matches)
+        (server-error 404 "NOT FOUND" output)
+        ((third (car matches)) input output request headers))
+      (close-input-port input)
+      (close-output-port output))
+    (socket-shutdown sock 2)
+    (socket-close sock))
+
+  ;; Extract headers from the input stream.
+  ;; Returns an alist to represent them.
+  (define (parse-headers input output)
+    (let loop ((line (read-line input))
+               (headers '()))
+      (if (string=? line "")
+        headers
+        (rxmatch-if (rxmatch #/^([^\s]+):\s*(.*)$/ line)
+                    (_ header value)
+          (loop (read-line input) (cons `(,header . ,value) headers))
+          (loop (read-line input) headers)))))
+
+  ;; Extract the request from the input stream.
+  ;; Returns a list of (method url).
+  (define (parse-request input output)
+    (let1 line (read-line input)
+      (rxmatch-if (rxmatch #/^([^\s]+)\s+([^\s]+)\s+HTTP\/1\.1$/ line)
+                  (_ method url)
+        (list method url)
+        (server-error 400 #`"BAD REQUEST - ,line" output))))
+
+  (define (server-newline port)
+    (display #\cr port)
+    (display #\lf port)
+    (if #f #f))
+
+  (define (server-error code msg port)
+    (display #`"HTTP/1.1 ,code ,msg")(newline)
+    (display #`"HTTP/1.1 ,code ,msg" port)
+    (server-newline port))
+
+  (define handlers '())
+
+  (define (add-handler! method regexp fn)
+    (set! handlers (cons (list method regexp fn) handlers)))
+
+  (define (server-start)
+    (let ((listener (make-server-socket 'inet 2357)))
+      (set-signal-handler! 2 (lambda (signum)
+                               (socket-shutdown listener 2)
+                               (socket-close listener)
+                               (exit 0)))
+      (let loop ((incoming (socket-accept listener)))
+        (display "Handling incoming...")(newline)
+        (dispatch incoming)
+        (display "Done.  Waiting for new one.")(newline)
+        (loop (socket-accept listener)))))
+
+  (define (server-stop)))