suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

reorganization

Browse Source 
svn: r2921
This commit is contained in:
Jay McCarthy 2006-05-12 16:37:05 +00:00
parent 29209ad625
commit 15381cd7f5
11 changed files with 212 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/web-server/configuration.ss
View File

@ -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"))

2
collects/web-server/connection-manager.ss
View File

@ -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.

3
collects/web-server/dispatch-servlets.ss
View File

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

0
collects/web-server/cache-table.ss → collects/web-server/private/cache-table.ss
View File

76
collects/web-server/private/url.ss Normal file
View File

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

11
collects/web-server/servlet-env.ss
View File

@ -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")
(require (lib "url.ss" "net")
(lib "sendurl.ss" "net")
(lib "unitsig.ss")
(lib "tcp-sig.ss" "net"))
"private/cache-table.ss")
(require "servlet.ss")
(provide (rename on-web:syntax on-web)
(all-from "servlet.ss"))

92
collects/web-server/servlet-helpers.ss
View File

@ -3,12 +3,10 @@
(lib "etc.ss")
(lib "xml.ss" "xml")
(lib "base64.ss" "net")
(lib "url.ss" "net")
(lib "struct.ss"))
(lib "url.ss" "net"))
(require "util.ss"
"response.ss"
"request-parsing.ss"
"servlet-tables.ss")
"request-parsing.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)
;; 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))))
translate-escapes)
;; get-host : Url (listof (cons Symbol String)) -> Symbol
;; host names are case insesitive---Internet RFC 1034

86
collects/web-server/servlet-tables.ss
View File

@ -1,9 +1,6 @@
(module servlet-tables mzscheme
(require (lib "contract.ss")
(lib "url.ss" "net")
(lib "list.ss")
(lib "plt-match.ss")
"timer.ss")
(require (lib "contract.ss"))
(require "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?)))]
[embed-ids (symbol? number? number? url? . -> . string?)]
[store-continuation! (procedure? procedure? url? servlet-instance? . -> . string?)]
[store-continuation! (procedure? procedure? servlet-instance? . -> . (list/c symbol? integer? integer?))]
[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)))
;; ********************************************************************************
;; 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)))))
(hash-table-remove! instance-table (servlet-instance-id inst))))

13
collects/web-server/servlet.ss
View File

@ -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 expiration-handler
(request-uri (execution-context-request ctxt))
inst)]
[k-embedding (store-continuation! k expiration-handler inst)]
[k-url (embed-ids
k-embedding
(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)

91
collects/web-server/url.ss Normal file
View File

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

40
collects/web-server/web-server-unit.ss
View File

@ -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)
(let loop ()
(thread-wait
(let* ([listener (tcp-listen config:port config:max-waiting
#t config:listen-ip)]
[get-ports
(lambda () (tcp-accept listener))])
(thread
(lambda ()
(with-handlers ([void (lambda (e)
; If the exception did not kill the listener
(with-handlers ([void void])
(tcp-close listener))
; Rethrow the error to this thread's error printer
(raise e))])
(server-loop get-ports
tcp-addresses))))))
(loop)))
(define (start-listener)
(let* ([listener (tcp-listen config:port config:max-waiting
#t config:listen-ip)]
[get-ports
(lambda () (tcp-accept listener))])
(with-handlers ([void (lambda (e)
; If the exception did not kill the listener
(with-handlers ([void void])
(tcp-close listener))
; Rethrow the error to this thread's error printer
(raise e))])
(server-loop get-ports
tcp-addresses))))
;; server-loop: (-> input-port output-port) (input-port -> string string) -> void
;; start a thread to handle each incoming connection