Commits

Taylor Venable committed 2377c98

Finish class-based dispatching for various matching classes.

Comments (0)

Files changed (1)

 (define-module www.server
   (export server-start          ; start the server
           add-handler!          ; add a handler
+          server-url-matcher    ; create a matched handler for URL
           server-newline)       ; write a \r\n newline
 
   (use gauche.net)
   (use srfi-1)
 
-  (define-class <server-handler> () (method constraints fn))
-  (define-class <server-match-constraint> () (kind info))
+  (use gauche.interactive)
+
+  (define-class <server-handler> ()
+    ((method            :init-keyword :method)
+     (constraints       :init-keyword :constraints)
+     (function          :init-keyword :function)))
+
+  (define-class <server-match-constraint> ()
+    ((kind              :init-keyword :kind)
+     (info              :init-keyword :info)))
+
+  (define-class <server-request> ()
+    ((method            :init-keyword :method)
+     (url               :init-keyword :url)
+     (headers           :init-keyword :headers)
+     (params            :init-keyword :params)))
 
   ;; Define a handler that matches only on URL.
   (define (server-url-matcher method url fn)
     (make <server-handler>
+          :function fn
           :method method
-          :constraints (list (make <server-match-constraint> :kind 'url url))))
+          :constraints (list (make <server-match-constraint> :kind 'url :info url))))
 
   ;; Define a handler that matches on URL and parameters.
   (define (server-param-matcher method url params fn)
     (make <server-handler>
+          :function fn
           :method method
-          :constraints (list (make <server-match-constraint> :kind 'url url)
-                             (make <server-match-constraint> :kind 'params params))))
+          :constraints (list (make <server-match-constraint> :kind 'url :info url)
+                             (make <server-match-constraint> :kind 'params :info params))))
+
+  (define (match-constraint handler request)
+    (cond ((eq? (slot-ref handler 'kind) 'url)
+           (rxmatch (slot-ref handler 'info) (slot-ref request 'url)))
+          (else
+            (error "unrecognized constraint kind" (symbol->string (slot-ref handler 'kind))))))
+
+  (define (match-handler handler request)
+    (and (eq? (slot-ref handler 'method)
+              (slot-ref request 'method))
+         (every (cut match-constraint <> request) (slot-ref handler 'constraints))))
 
   (define (dispatch sock)
     (let* ((input (socket-input-port sock))
            (output (socket-output-port sock))
-           (request (parse-request input output))
+           (request-line (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)
+           (request (make <server-request> :method (car request-line)
+                                           :url (cadr request-line)
+                                           :headers headers))
+           (matches (filter (cut match-handler <> request) handlers)))
       (if (null? matches)
         (server-error 404 "NOT FOUND" output)
-        ((third (car matches)) input output request headers))
+        ((slot-ref (car matches) 'function) input output request headers))
+      (flush output)
       (close-input-port input)
       (close-output-port output))
-    (socket-shutdown sock 2)
+    ;(socket-shutdown sock 2)
     (socket-close sock))
 
   ;; Extract headers from the input stream.
     (let1 line (read-line input)
       (rxmatch-if (rxmatch #/^([^\s]+)\s+([^\s]+)\s+HTTP\/1\.1$/ line)
                   (_ method url)
-        (list method url)
+        (let ((method (cond ((string=? method "GET") 'get)
+                            ((string=? method "POST") 'post)
+                            (else
+                              (error "unsupported request method" method)))))
+          (list method url))
         (server-error 400 #`"BAD REQUEST - ,line" output))))
 
   (define (server-newline port)