reorganization

svn: r2921

collects/web-server/configuration.ss

@@ -5,7 +5,7 @@
            "sig.ss"
            "util.ss"
            "parse-table.ss"
-           "cache-table.ss"
+           "private/cache-table.ss"
            "response.ss")
   (require (lib "unitsig.ss")
            (lib "contract.ss"))

collects/web-server/connection-manager.ss

@@ -1,4 +1,4 @@
-;; this is an trivial implementation of the connection-manger interface that
+;; this is a trivial implementation of the connection-manger interface that
 ;; uses timeouts instead of a queued-model.
 
 ;; the queued-model is also fully implemented but won't be used at this time.

collects/web-server/dispatch-servlets.ss

@@ -10,7 +10,8 @@
            "sig.ss"
            "timer.ss"
            "util.ss"
-           "cache-table.ss")  
+           "private/url.ss"
+           "private/cache-table.ss")  
   (provide interface-version
            gen-dispatcher)
   

collects/web-server/private/url.ss

@@ -0,0 +1,76 @@
+(module url mzscheme
+  (require (lib "contract.ss")
+           (lib "url.ss" "net")
+           (lib "list.ss")
+           (lib "plt-match.ss"))
+  
+  (provide
+   match-url-params)
+  (provide/contract
+   [continuation-url? (url? . -> . (or/c boolean? (list/c symbol? number? number?)))]
+   [embed-ids ((list/c symbol? number? number?) url? . -> . string?)])
+  
+  ;; ********************************************************************************
+  ;; Parameter Embedding
+  
+  (define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*([^\\*]*)\\*([^\\*]*)"))
+  
+  (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
+  
+  ;; embed-ids: (list number number number) url -> string
+  (define embed-ids
+    (match-lambda*
+      [(list (list inst-id k-id salt) in-url)
+       (insert-param
+        in-url
+        (format "~a*~a*~a" inst-id k-id salt))]))
+  
+  ;; continuation-url?: url -> (or/c (list number number number) #f)
+  ;; determine if this url encodes a continuation and extract the instance id and
+  ;; continuation id.
+  (define (continuation-url? a-url)
+    (let ([k-params (filter match-url-params
+                            (apply append (map path/param-param (url-path a-url))))])
+      (if (empty? k-params)
+          #f
+          (match (match-url-params (first k-params))
+            [(list s instance k-id salt)
+             (let ([k-id/n (string->number k-id)]
+                   [salt/n (string->number salt)])
+               (if (and (number? k-id/n)
+                        (number? salt/n))
+                   (list (string->symbol instance)
+                         k-id/n
+                         salt/n)
+                   ; XXX: Maybe log this in some way?
+                   #f))]))))
+  
+  ;; insert-param: url string -> string
+  ;; add a path/param to the path in a url
+  ;; (assumes that there is only one path/param)
+  (define (insert-param in-url new-param-str)
+    (url->string
+     (replace-path
+      (lambda (old-path)        
+        (if (empty? old-path)
+            (list (make-path/param "" (list new-param-str)))
+            (list* (make-path/param (path/param-path (first old-path))
+                                    (list new-param-str))
+                   (rest old-path))))
+      in-url)))
+  
+  ;; replace-path: (url-path -> url-path) url -> url
+  ;; make a new url by replacing the path part of a url with a function
+  ;; of the url's old path
+  ;; also remove the query
+  (define (replace-path proc in-url)
+    (let ([new-path (proc (url-path in-url))])
+      (make-url
+       (url-scheme in-url)
+       (url-user in-url)
+       (url-host in-url)
+       (url-port in-url)
+       (url-path-absolute? in-url)
+       new-path
+       empty
+       (url-fragment in-url)))))

collects/web-server/servlet-env.ss

@@ -1,17 +1,14 @@
 (module servlet-env mzscheme
+  (require (lib "sendurl.ss" "net")
+           (lib "unitsig.ss"))
   (require "configuration.ss"
            "web-server.ss"
            "sig.ss"
-           "servlet.ss"
-           "connection-manager.ss"
            "servlet-tables.ss"
            "util.ss"
            "response.ss"
-           "cache-table.ss")
+           "private/cache-table.ss")
-  (require (lib "url.ss" "net")
+  (require "servlet.ss")
-           (lib "sendurl.ss" "net")
-           (lib "unitsig.ss")
-           (lib "tcp-sig.ss" "net"))
   (provide (rename on-web:syntax on-web)
            (all-from "servlet.ss"))
   

collects/web-server/servlet-helpers.ss

@@ -3,12 +3,10 @@
            (lib "etc.ss")
            (lib "xml.ss" "xml")
            (lib "base64.ss" "net")
-           (lib "url.ss" "net")
+           (lib "url.ss" "net"))
-           (lib "struct.ss"))
   (require "util.ss"
            "response.ss"
-           "request-parsing.ss"
+           "request-parsing.ss")
-           "servlet-tables.ss")
   (provide get-host
            extract-binding/single
            extract-bindings
@@ -23,91 +21,7 @@
            see-other
            (all-from "request-parsing.ss")
            (rename get-parsed-bindings request-bindings)
-           translate-escapes)
+           translate-escapes)    
-  
-  ;; URL parsing
-  (provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path))
-           servlet-url->url-string
-           servlet-url->url-string/no-continuation
-           servlet-url->servlet-url/no-extra-path 
-           request->servlet-url
-           uri->servlet-url)
-  (define-struct servlet-url (protocol host port
-                                       servlets-root 
-                                       instance-id k-id nonce 
-                                       servlet-path extra-path))
-  (define (servlet-url->url-string/no-continuation su)
-    (url->string
-     (make-url (servlet-url-protocol su)
-               #f
-               #f ;(servlet-url-host su)
-               #f ;(servlet-url-port su)
-               #t
-               (append (map (lambda (p/p)
-                              (if (and (not (empty? (path/param-param p/p)))
-                                       ; XXX: not robust
-                                       (match-url-params (first (path/param-param p/p))))
-                                  (make-path/param (path/param-path p/p) empty)
-                                  p/p))
-                            (servlet-url-servlets-root su))
-                       (servlet-url-servlet-path su)
-                       (servlet-url-extra-path su))
-               empty
-               #f)))
-  (define (servlet-url->url-string su)
-    (let ([the-url
-           (make-url (servlet-url-protocol su)
-                         #f
-                         #f ;(servlet-url-host su)
-                         #f ;(servlet-url-port su)
-                         #t
-                         (append (reverse (rest (reverse (servlet-url-servlets-root su))))
-                                 (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su))))
-                                                        empty))
-                                 (servlet-url-servlet-path su)
-                                 (servlet-url-extra-path su))
-                         empty
-                         #f)])
-      (if (and (servlet-url-instance-id su)
-               (servlet-url-k-id su) 
-               (servlet-url-nonce su))               
-          (embed-ids (servlet-url-instance-id su)
-                     (servlet-url-k-id su) 
-                     (servlet-url-nonce su)
-                     the-url)
-          (url->string the-url))))
-  (define (servlet-url->servlet-url/no-extra-path su)
-    (copy-struct servlet-url su
-                 [servlet-url-extra-path empty]))
-  (define (request->servlet-url req)
-    (uri->servlet-url (request-uri req)
-                      (request-host-ip req)
-                      (request-host-port req)))
-  (define uri->servlet-url
-    (opt-lambda (uri [default-host #f] [default-port #f])
-      (let-values ([(k-instance k-id k-salt)
-                    (let ([k-parts (continuation-url? uri)])
-                      (if k-parts
-                          (apply values k-parts)
-                          (values #f #f #f)))]
-                   [(servlet-path path)
-                    (let loop ([servlet-path empty]
-                               [path (rest (url-path uri))])
-                      (if (empty? path)
-                          (values servlet-path path)
-                          (let ([cur (first path)])
-                            (if (regexp-match "\\.ss$" (path/param-path cur))
-                                (values (append servlet-path (list cur))
-                                        (rest path))
-                                (loop (append servlet-path (list cur))
-                                      (rest path))))))])
-        (make-servlet-url (url-scheme uri)
-                          (or (url-host uri) default-host)
-                          (or (url-port uri) default-port)
-                          (list (first (url-path uri)))
-                          k-instance k-id k-salt
-                          servlet-path
-                          path))))
   
   ;; get-host : Url (listof (cons Symbol String)) -> Symbol
   ;; host names are case insesitive---Internet RFC 1034

collects/web-server/servlet-tables.ss

@@ -1,9 +1,6 @@
 (module servlet-tables mzscheme
-  (require (lib "contract.ss")
+  (require (lib "contract.ss"))
-           (lib "url.ss" "net")
+  (require "timer.ss")
-           (lib "list.ss")
-           (lib "plt-match.ss")
-           "timer.ss")
   (provide (struct exn:servlet:instance ())
            (struct exn:servlet:no-current-instance ())
            (struct exn:servlet:continuation (expiration-handler))
@@ -35,12 +32,8 @@
   ;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the
   ;;   case when it is attempted to invoke multiple continuations
   ;;   simultaneously.
-  (provide
-   match-url-params)
   (provide/contract
-   [continuation-url? (url? . -> . (or/c boolean? (list/c symbol? number? number?)))]
+   [store-continuation! (procedure? procedure? servlet-instance? . -> . (list/c symbol? integer? integer?))]
-   [embed-ids (symbol? number? number? url? . -> . string?)]
-   [store-continuation! (procedure? procedure? url? servlet-instance? . -> . string?)]
    [create-new-instance! (hash-table? custodian? execution-context? semaphore? timer?
                                       . -> . servlet-instance?)]
    [remove-instance! (hash-table? servlet-instance? . -> . any)]
@@ -78,7 +71,7 @@
                   (hash-table-put! k-table1 id v)
                   ; Replace continuations with #f
                   (hash-table-put! k-table1 id (list* #f (cdr v))))))
-           k-table1))            
+           k-table1))
 
        ;; get-k-id!: hash-table -> number
        ;; get the current-continuation id and increment the internal value
@@ -87,14 +80,14 @@
            (hash-table-put! k-table id-slot (add1 id))
            id)))))
 
-  ;; store-continuation!: continuation expiration-handler uri servlet-instance -> url-string
+  ;; store-continuation!: continuation expiration-handler servlet-instance -> (list symbol? integer? integer?)
   ;; store a continuation in a k-table for the provided servlet-instance
-  (define (store-continuation! k expiration-handler uri inst)
+  (define (store-continuation! k expiration-handler inst)
     (let ([k-table (servlet-instance-k-table inst)])
       (let ([next-k-id (get-k-id! k-table)]
             [salt      (random 100000000)])
         (hash-table-put! k-table next-k-id (list k expiration-handler salt))
-        (embed-ids (servlet-instance-id inst) next-k-id salt uri))))
+        (list (servlet-instance-id inst) next-k-id salt))))
 
   ;; clear-continuations!: servlet-instance -> void
   ;; replace the k-table for the given servlet-instance
@@ -115,67 +108,4 @@
 
   ;; remove-instance!: hash-table servlet-instance -> void
   (define (remove-instance! instance-table inst)
-    (hash-table-remove! instance-table (servlet-instance-id inst)))
+    (hash-table-remove! instance-table (servlet-instance-id inst))))
-
-  ;; ********************************************************************************
-  ;; Parameter Embedding
-
-  (define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*([^\\*]*)\\*([^\\*]*)"))
-
-  (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
-
-  ;; embed-ids: number number number url -> string
-  (define (embed-ids inst-id k-id salt in-url)
-    (insert-param
-     in-url
-     (format "~a*~a*~a" inst-id k-id salt)))
-
-  ;; continuation-url?: url -> (or/c (list number number number) #f)
-  ;; determine if this url encodes a continuation and extract the instance id and
-  ;; continuation id.
-  (define (continuation-url? a-url)
-    (let ([k-params (filter match-url-params
-                            (apply append (map path/param-param (url-path a-url))))])
-      (if (empty? k-params)
-          #f
-          (match (match-url-params (first k-params))
-            [(list s instance k-id salt)
-             (let ([k-id/n (string->number k-id)]
-                   [salt/n (string->number salt)])
-               (if (and (number? k-id/n)
-                        (number? salt/n))
-                   (list (string->symbol instance)
-                         k-id/n
-                         salt/n)
-                   ; XXX: Maybe log this in some way?
-                   #f))]))))
-  
-  ;; insert-param: url string -> string
-  ;; add a path/param to the path in a url
-  ;; (assumes that there is only one path/param)
-  (define (insert-param in-url new-param-str)
-    (url->string
-     (replace-path
-      (lambda (old-path)        
-        (if (empty? old-path)
-            (list (make-path/param "" (list new-param-str)))
-            (list* (make-path/param (path/param-path (first old-path))
-                                    (list new-param-str))
-                   (rest old-path))))
-      in-url)))
-
-  ;; replace-path: (url-path -> url-path) url -> url
-  ;; make a new url by replacing the path part of a url with a function
-  ;; of the url's old path
-  ;; also remove the query
-  (define (replace-path proc in-url)
-    (let ([new-path (proc (url-path in-url))])
-      (make-url
-       (url-scheme in-url)
-       (url-user in-url)
-       (url-host in-url)
-       (url-port in-url)
-       (url-path-absolute? in-url)
-       new-path
-       empty
-       (url-fragment in-url)))))

collects/web-server/servlet.ss

@@ -4,6 +4,7 @@
            (lib "xml.ss" "xml"))
   (require "servlet-tables.ss"
            "response.ss"
+           "private/url.ss"
            "servlet-helpers.ss"
            "timer.ss"
            "web-cells.ss")
@@ -72,9 +73,11 @@
    [send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)]
    [send/suspend/callback (xexpr/callback? . -> . any/c)])
   
+  (require "url.ss")
   (provide
    (all-from "web-cells.ss")
-   (all-from "servlet-helpers.ss"))
+   (all-from "servlet-helpers.ss")
+   (all-from "url.ss"))
   
   ;; ************************************************************
   ;; EXPORTS
@@ -123,10 +126,10 @@
        (let/cc k
          (let* ([inst (get-current-servlet-instance)]
                 [ctxt (servlet-instance-context inst)]
-                [k-url (store-continuation!
+                [k-embedding (store-continuation! k expiration-handler inst)]
-                        k expiration-handler
+                [k-url (embed-ids 
-                        (request-uri (execution-context-request ctxt))
+                        k-embedding
-                        inst)]
+                        (request-uri (execution-context-request ctxt)))]
                 [k-url ((current-url-transform) k-url)]
                 [response (response-generator k-url)])
            (output-response (execution-context-connection ctxt) response)

collects/web-server/url.ss

@@ -0,0 +1,91 @@
+(module url mzscheme
+  (require (lib "list.ss")
+           (lib "etc.ss")
+           (lib "url.ss" "net")
+           (lib "struct.ss"))
+  (require "private/url.ss"
+           "request-parsing.ss")
+           
+  ;; URL parsing
+  (provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path))
+           servlet-url->url-string
+           servlet-url->url-string/no-continuation
+           servlet-url->servlet-url/no-extra-path 
+           request->servlet-url
+           uri->servlet-url)
+  (define-struct servlet-url (protocol host port
+                                       servlets-root 
+                                       instance-id k-id nonce 
+                                       servlet-path extra-path))
+  (define (servlet-url->url-string/no-continuation su)
+    (url->string
+     (make-url (servlet-url-protocol su)
+               #f
+               #f ;(servlet-url-host su)
+               #f ;(servlet-url-port su)
+               #t
+               (append (map (lambda (p/p)
+                              (if (and (not (empty? (path/param-param p/p)))
+                                       ; XXX: not robust
+                                       (match-url-params (first (path/param-param p/p))))
+                                  (make-path/param (path/param-path p/p) empty)
+                                  p/p))
+                            (servlet-url-servlets-root su))
+                       (servlet-url-servlet-path su)
+                       (servlet-url-extra-path su))
+               empty
+               #f)))
+  (define (servlet-url->url-string su)
+    (let ([the-url
+           (make-url (servlet-url-protocol su)
+                         #f
+                         #f ;(servlet-url-host su)
+                         #f ;(servlet-url-port su)
+                         #t
+                         (append (reverse (rest (reverse (servlet-url-servlets-root su))))
+                                 (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su))))
+                                                        empty))
+                                 (servlet-url-servlet-path su)
+                                 (servlet-url-extra-path su))
+                         empty
+                         #f)])
+      (if (and (servlet-url-instance-id su)
+               (servlet-url-k-id su) 
+               (servlet-url-nonce su))               
+          (embed-ids (list (servlet-url-instance-id su)
+                           (servlet-url-k-id su) 
+                           (servlet-url-nonce su))
+                     the-url)
+          (url->string the-url))))
+  (define (servlet-url->servlet-url/no-extra-path su)
+    (copy-struct servlet-url su
+                 [servlet-url-extra-path empty]))
+  (define (request->servlet-url req)
+    (uri->servlet-url (request-uri req)
+                      (request-host-ip req)
+                      (request-host-port req)))
+  (define uri->servlet-url
+    (opt-lambda (uri [default-host #f] [default-port #f])
+      (let-values ([(k-instance k-id k-salt)
+                    (let ([k-parts (continuation-url? uri)])
+                      (if k-parts
+                          (apply values k-parts)
+                          (values #f #f #f)))]
+                   [(servlet-path path)
+                    (let loop ([servlet-path empty]
+                               [path (rest (url-path uri))])
+                      (if (empty? path)
+                          (values servlet-path path)
+                          (let ([cur (first path)])
+                            (if (regexp-match "\\.ss$" (path/param-path cur))
+                                (values (append servlet-path (list cur))
+                                        (rest path))
+                                (loop (append servlet-path (list cur))
+                                      (rest path))))))])
+        (make-servlet-url (url-scheme uri)
+                          (or (url-host uri) default-host)
+                          (or (url-port uri) default-port)
+                          (list (first (url-path uri)))
+                          k-instance k-id k-salt
+                          servlet-path
+                          path)))))

collects/web-server/web-server-unit.ss

@@ -4,7 +4,7 @@
            "connection-manager.ss"
            "configuration-structures.ss"
            "servlet.ss"
-           "cache-table.ss"
+           "private/cache-table.ss"
            (rename "request-parsing.ss" 
                    the-read-request read-request))
   (require (prefix sequencer: "dispatch-sequencer.ss")
@@ -31,33 +31,29 @@
         (let ([the-server-custodian (make-custodian)])
           (start-connection-manager the-server-custodian)
           (parameterize ([current-custodian the-server-custodian]
-                         [current-server-custodian the-server-custodian])
+                         [current-server-custodian the-server-custodian]
+                         [current-thread-initial-stack-size 3])
             (thread
              (lambda ()
-               (listener-loop))))
+               (start-listener))))
           (lambda ()
             (custodian-shutdown-all the-server-custodian))))
       
-      ;; listener-loop : -> void
+      ;; start-listener : -> void
       ;; loops around starting a listener if the current listener dies
-      (define (listener-loop)
+      (define (start-listener)
-        (let loop ()
+        (let* ([listener (tcp-listen config:port config:max-waiting
-          (thread-wait
+                                     #t config:listen-ip)]
-           (let* ([listener (tcp-listen config:port config:max-waiting
+               [get-ports
-                                        #t config:listen-ip)]
+                (lambda () (tcp-accept listener))])
-                  [get-ports
+          (with-handlers ([void (lambda (e)
-                   (lambda () (tcp-accept listener))])
+                                  ; If the exception did not kill the listener
-             (thread
+                                  (with-handlers ([void void])
-              (lambda ()
+                                    (tcp-close listener))
-                (with-handlers ([void (lambda (e)
+                                  ; Rethrow the error to this thread's error printer
-                                        ; If the exception did not kill the listener
+                                  (raise e))])
-                                        (with-handlers ([void void])
+            (server-loop get-ports
-                                          (tcp-close listener))
+                         tcp-addresses))))
-                                        ; Rethrow the error to this thread's error printer
-                                        (raise e))])
-                  (server-loop get-ports
-                               tcp-addresses))))))
-          (loop)))
       
       ;; server-loop: (-> input-port output-port) (input-port -> string string) -> void
       ;; start a thread to handle each incoming connection