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

Removing usable of lib paths and collection paths in Web server re: Planet 2 extensions

Browse Source
This commit is contained in:
Jay McCarthy 2012-11-24 09:21:49 -07:00
parent accdcb755a
commit 34d2c7b263
14 changed files with 103 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/tests/web-server/dispatchers/dispatch-lang-test.rkt
View File

@ -2,6 +2,8 @@
(require rackunit
mzlib/etc
mzlib/list
racket/path
racket/runtime-path
web-server/dispatchers/dispatch
web-server/http
web-server/configuration/namespace
@ -39,7 +41,11 @@
(raise exn))))
d)
(define example-servlets (build-path (collection-path "web-server") "default-web-root" "htdocs" "lang-servlets/"))
(define-runtime-path default-web-root
"../../../web-server/default-web-root")
(define example-servlets
(build-path default-web-root "htdocs" "lang-servlets/"))
(define dispatch-lang-tests
(test-suite
@ -141,7 +147,9 @@
(let* ([d (mkd (build-path example-servlets "check-dir.rkt"))]
[t0 (simple-xpath* '(h2) (call d url0 empty))])
t0)
(format "The current directory: ~a" (path->string example-servlets)))
(format "The current directory: ~a/"
(path->string
(normalize-path example-servlets))))
; XXX Use kont
#;(test-equal? "quiz01.rkt"

6
collects/tests/web-server/dispatchers/dispatch-passwords-test.rkt
View File

@ -4,6 +4,7 @@
make-temporary-file)
net/url
racket/promise
racket/runtime-path
racket/list
racket/serialize
web-server/http
@ -15,7 +16,10 @@
(require/expose web-server/dispatchers/dispatch-passwords
(read-passwords))
(define default-passwords (build-path (collection-path "web-server") "default-web-root" "passwords"))
(define-runtime-path default-web-root
"../../../web-server/default-web-root")
(define default-passwords (build-path default-web-root "passwords"))
(define test-passwords (make-temporary-file))
(define (write-test-passwords!)
(with-output-to-file test-passwords

49
collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt
View File

@ -2,6 +2,8 @@
(require rackunit
mzlib/etc
mzlib/list
racket/runtime-path
racket/path
xml
web-server/http
web-server/private/cache-table
@ -30,23 +32,25 @@
(raise exn))))
d)
(define example-servlets
(build-path (collection-path "web-server") "default-web-root" "htdocs" "servlets" "examples/"))
(define-runtime-path default-web-root
"../../../web-server/default-web-root")
(define example-servlets
(build-path default-web-root "htdocs" "servlets" "examples/"))
(define dispatch-servlets-tests
(test-suite
"Servlets"
; XXX test update cache
; XXX redirect/get
; XXX web-cells
; XXX test update cache
; XXX redirect/get
; XXX web-cells
(test-pred "configure.rkt"
string?
(let* ([d (mkd (build-path example-servlets 'up "configure.rkt"))]
[k0 (simple-xpath* '(form #:action) (call d url0 empty))])
k0))
(test-suite
"Examples"
(test-equal? "hello.rkt - loading"
@ -92,10 +96,13 @@
(list (list "1" "1")
(list "2" "1")))
(test-equal? "dir.rkt - current-directory"
(let* ([d (mkd (build-path example-servlets "dir.rkt"))]
[t0 (simple-xpath* '(p em) (call d url0 empty))])
t0)
(path->string example-servlets))
(path->string
(normalize-path
(let* ([d (mkd (build-path example-servlets "dir.rkt"))]
[t0 (simple-xpath* '(p em) (call d url0 empty))])
t0)))
(path->string
(normalize-path example-servlets)))
(test-pred "quiz.rkt - send/suspend"
string?
(let* ([d (mkd (build-path example-servlets "quiz.rkt"))])
@ -116,21 +123,21 @@
(list "Expired"
"Done."
"Expired"))
(test-double-counters
mkd
"wc-fake.rkt - no cells"
(build-path example-servlets "wc-fake.rkt"))
(test-double-counters
mkd
"wc.rkt - make-web-cell web-cell-ref web-cell-shadow"
(build-path example-servlets "wc.rkt"))
; XXX Broken
; XXX Broken
#;(test-equal? "adjust.rkt - adjust-timeout!"
(let* ([d (mkd (build-path example-servlets "adjust.rkt"))]
[k0 (first ((sxpath "//a/@href/text()") (call d url0 empty)))])
(sleep 3)
(call d k0 empty))
"#"))))
(let* ([d (mkd (build-path example-servlets "adjust.rkt"))]
[k0 (first ((sxpath "//a/@href/text()") (call d url0 empty)))])
(sleep 3)
(call d k0 empty))
"#"))))

5
collects/tests/web-server/dispatchers/filesystem-map-test.rkt
View File

@ -2,10 +2,13 @@
(require rackunit
net/url
web-server/private/util
racket/runtime-path
web-server/dispatchers/filesystem-map)
(provide filesystem-map-tests)
(define base-dir (collection-path "web-server"))
(define-runtime-path base-dir
"../../../web-server")
(define test-map (make-url->path base-dir))
(define test-valid-map (make-url->valid-path test-map))
(define test-filter-map (filter-url->path #rx"\\.(ss|scm|rkt)$" test-map))

66
collects/tests/web-server/lang-test.rkt
View File

@ -33,7 +33,7 @@
"Function application with single argument in tail position"
(let-values ([(test-m00.4)
(make-module-eval
(module m00.4 (lib "lang.rkt" "web-server")
(module m00.4 web-server/lang
(provide start)
(define (start initial)
(let ([f (let ([m 7]) m)])
@ -44,7 +44,7 @@
"set!"
(let-values ([(test-m00.4)
(make-module-eval
(module m00.4 (lib "lang.rkt" "web-server")
(module m00.4 web-server/lang
(provide start)
(define x 1)
(define (start initial)
@ -57,7 +57,7 @@
"Embedded Definitions"
(let-values ([(test-m00.4)
(make-module-eval
(module m00.4 (lib "lang.rkt" "web-server")
(module m00.4 web-server/lang
(provide start)
(define (start initial)
(define m 7)
@ -69,7 +69,7 @@
"Embedded Definitions + Intermixed expressions"
(let-values ([(test-m00.4)
(make-module-eval
(module m00.4 (lib "lang.rkt" "web-server")
(module m00.4 web-server/lang
(provide start)
(define (start initial)
(define m 7)
@ -82,7 +82,7 @@
"start-interaction in argument position of a function call"
(let-values ([(test-m00.3)
(make-module-eval
(module m00.3 (lib "lang.rkt" "web-server")
(module m00.3 web-server/lang
(define (foo x) 'foo)
(provide start)
(define (start initial)
@ -93,7 +93,7 @@
"identity interaction, dispatch-start called multiple times"
(let-values ([(test-m00)
(make-module-eval
(module m00 (lib "lang.rkt" "web-server")
(module m00 web-server/lang
(define (id x) x)
(provide start)
(define (start initial)
@ -105,7 +105,7 @@
"start-interaction in argument position of a primitive"
(let-values ([(test-m00.1)
(make-module-eval
(module m00.1 (lib "lang.rkt" "web-server")
(module m00.1 web-server/lang
(provide start)
(define (start initial)
(+ 1 initial))))])
@ -115,7 +115,7 @@
"dispatch-start called multiple times for s-i in non-trivial context"
(let-values ([(test-m00.2)
(make-module-eval
(module m00.2 (lib "lang.rkt" "web-server")
(module m00.2 web-server/lang
(provide start)
(define (start initial)
(+ (+ 1 1) initial))))])
@ -126,7 +126,7 @@
"start-interaction in third position"
(let-values ([(test-m01)
(make-module-eval
(module m01 (lib "lang.rkt" "web-server")
(module m01 web-server/lang
(provide start)
(define (start initial)
(+ (* 1 2) (* 3 4) initial))))])
@ -139,7 +139,7 @@
"begin with intermediate multiple values"
(let-values ([(test)
(make-module-eval
(module m03 (lib "lang.rkt" "web-server")
(module m03 web-server/lang
(provide start)
(define (start x)
(begin (printf "Before\n")
@ -152,7 +152,7 @@
"begin0 with intermediate multiple values"
(let-values ([(test)
(make-module-eval
(module m03 (lib "lang.rkt" "web-server")
(module m03 web-server/lang
(provide start)
(define (start x)
(begin0 x
@ -165,7 +165,7 @@
"begin0 with multiple values"
(let-values ([(test)
(make-module-eval
(module m03 (lib "lang.rkt" "web-server")
(module m03 web-server/lang
(provide start)
(define (start x)
(let-values ([(_ ans)
@ -183,7 +183,7 @@
"continuation invoked in non-trivial context from within proc"
(let-values ([(test-m03)
(make-module-eval
(module m03 (lib "lang.rkt" "web-server")
(module m03 web-server/lang
(provide start)
(define (start x)
(let/cc k
@ -198,7 +198,7 @@
"non-tail-recursive 'escaping' continuation"
(let-values ([(test-m04)
(make-module-eval
(module m04 (lib "lang.rkt" "web-server")
(module m04 web-server/lang
(provide start)
(define (start ln)
(let/cc k
@ -219,7 +219,7 @@
"tail-recursive escaping continuation"
(let-values ([(test-m05)
(make-module-eval
(module m05 (lib "lang.rkt" "web-server")
(module m05 web-server/lang
(provide start)
(define (start ln)
@ -259,7 +259,7 @@
(define (lookup-k key-pair)
(hash-ref the-table (car key-pair) (lambda () #f)))))])
(table-01-eval
'(module m06 (lib "lang.rkt" "web-server")
'(module m06 web-server/lang
(require 'table01)
(provide start)
@ -290,7 +290,7 @@
(let-values ([(test-m06.1)
(make-module-eval
(module m06.1 (lib "lang.rkt" "web-server")
(module m06.1 web-server/lang
(provide start)
(define (gn which)
(cadr
@ -317,7 +317,7 @@
(let-values ([(test-m06.2)
(make-module-eval
(module m06.2 (lib "lang.rkt" "web-server")
(module m06.2 web-server/lang
(provide start)
(define (gn #:page which)
(cadr
@ -349,7 +349,7 @@
"quasi-quote with splicing: need to recertify context for qq-append"
(let-values ([(test-m01.1)
(make-module-eval
(module m01.1 (lib "lang.rkt" "web-server")
(module m01.1 web-server/lang
(provide start)
(define (start initial)
`(,@(list 1 2 initial)))))])
@ -360,7 +360,7 @@
"recertify context test (1)"
(let-values ([(test-m01.2)
(make-module-eval
(module m01.1 (lib "lang.rkt" "web-server")
(module m01.1 web-server/lang
(provide start)
(define (start initial)
`(foo ,@(list 1 2 3)))))])
@ -370,7 +370,7 @@
"recertify context test (2)"
(let-values ([(test-m01.3)
(make-module-eval
(module m01.3 (lib "lang.rkt" "web-server")
(module m01.3 web-server/lang
(provide start)
(define (start n)
`(n ,@(list 1 2 3)))))])
@ -380,7 +380,7 @@
"recertify context test (3)"
(let-values ([(test-m01.4)
(make-module-eval
(module m1 (lib "lang.rkt" "web-server")
(module m1 web-server/lang
(provide start)
(define (start initial)
(define (bar n)
@ -395,7 +395,7 @@
"mutually recursive even? and odd?"
(let-values ([(test-m07)
(make-module-eval
(module m07 (lib "lang.rkt" "web-server")
(module m07 web-server/lang
(provide start)
(define (start initial)
(letrec ([even? (lambda (n)
@ -414,7 +414,7 @@
"call-with-serializable-current-continuation on rhs of letrec binding forms"
(let-values ([(test-m08)
(make-module-eval
(module m08 (lib "lang.rkt" "web-server")
(module m08 web-server/lang
(provide start)
(define (gn which)
(cadr
@ -456,7 +456,7 @@
(let ([result (apply f args)])
(printf "result = ~s\n" result)
result))))])
(nta-eval '(module m09 (lib "lang.rkt" "web-server")
(nta-eval '(module m09 web-server/lang
(require 'nta)
(provide start)
(define (start ignore)
@ -472,7 +472,7 @@
(let-values ([(m10-eval)
(make-module-eval
(module m10 (lib "lang.rkt" "web-server")
(module m10 web-server/lang
(provide start)
(define (nta f arg)
(let ([result (f arg)])
@ -487,7 +487,7 @@
(let-values ([(m11-eval)
(make-module-eval
(module m11 (lib "lang.rkt" "web-server")
(module m11 web-server/lang
(provide start)
(define (start ignore)
(map
@ -509,7 +509,7 @@
(define (tail-apply f . args)
(apply f args))))])
(ta-eval '(module m12 (lib "lang.rkt" "web-server")
(ta-eval '(module m12 web-server/lang
(require 'ta)
(provide start)
(define (start initial)
@ -525,7 +525,7 @@
(let-values ([(m13-eval)
(make-module-eval
(module m11 (lib "lang.rkt" "web-server")
(module m11 web-server/lang
(provide start)
(define (start initial)
(map
@ -548,7 +548,7 @@
(define (tail-apply f . args)
(apply f args))))])
(ta-eval '(module m14 (lib "lang.rkt" "web-server")
(ta-eval '(module m14 web-server/lang
(require 'ta)
(provide start)
(define (start ignore)
@ -573,7 +573,7 @@
(check-not-exn
(lambda ()
(make-module-eval
(module data (lib "lang.rkt" "web-server")
(module data web-server/lang
(require mzlib/contract)
(define x 1)
@ -586,7 +586,7 @@
(check-not-exn
(lambda ()
(make-module-eval
(module data (lib "lang.rkt" "web-server")
(module data web-server/lang
(require mzlib/contract)
(define-struct posn (x y) #:mutable)
@ -598,7 +598,7 @@
(check-not-exn
(lambda ()
(make-module-eval
(module test (lib "lang.rkt" "web-server")
(module test web-server/lang
(define (show-user)
(define-values (point i) (values #t 1))
i)))))))))

4
collects/tests/web-server/lang/stuff-url-test.rkt
View File

@ -23,8 +23,8 @@
(lambda (k*v)
((car k*v) k*v))))
(define m00 '(lib "mm00.rkt" "web-server" "default-web-root" "htdocs" "lang-servlets"))
(define m01 '(lib "mm01.rkt" "web-server" "default-web-root" "htdocs" "lang-servlets"))
(define m00 'web-server/default-web-root/htdocs/lang-servlets/mm00)
(define m01 'web-server/default-web-root/htdocs/lang-servlets/mm01)
(define stuff-url-tests
(test-suite

4
collects/tests/web-server/lang/web-param-test.rkt
View File

@ -19,7 +19,7 @@
"web-parameterize does not overwrite with multiple parameters"
(let-values ([(meval)
(make-module-eval
(module m (lib "lang.rkt" "web-server")
(module m web-server/lang
(define first (make-web-parameter #f))
(define second (make-web-parameter #f))
(provide start)
@ -34,7 +34,7 @@
(let-values ([(meval)
(make-module-eval
(module m (lib "lang.rkt" "web-server")
(module m web-server/lang
(provide start)
(define first (make-web-parameter #f))
(define second (make-web-parameter #f))

6
collects/tests/web-server/private/mime-types-test.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require rackunit
(only-in mzlib/file make-temporary-file)
racket/runtime-path
web-server/http
web-server/private/mime-types)
(provide mime-types-tests)
@ -15,13 +16,16 @@ END
))
#:exists 'replace)
(define-runtime-path default-web-root
"../../../web-server/default-web-root")
(define mime-types-tests
(test-suite
"MIME Types"
(test-case
"Distribution mime.types parses"
(check-not-false (read-mime-types (build-path (collection-path "web-server") "default-web-root" "mime.types"))))
(check-not-false (read-mime-types (build-path default-web-root "mime.types"))))
(test-case
"Test file parses"

4
collects/tests/web-server/private/mod-map-test.rkt
View File

@ -19,8 +19,8 @@
(lambda (k*v)
((car k*v) k*v))))
(define m00 '(lib "mm00.rkt" "web-server" "default-web-root" "htdocs" "lang-servlets"))
(define m01 '(lib "mm01.rkt" "web-server" "default-web-root" "htdocs" "lang-servlets"))
(define m00 'web-server/default-web-root/htdocs/lang-servlets/mm00)
(define m01 'web-server/default-web-root/htdocs/lang-servlets/mm01)
(define mod-map-tests
(test-suite

3
collects/web-server/configuration/configuration-table.rkt
View File

@ -17,8 +17,7 @@
[default-configuration-table-path path?])
(define-runtime-path default-configuration-table-path
(list 'lib
"web-server/default-web-root/configuration-table.rkt"))
"../default-web-root/configuration-table.rkt")
(define (get-binding key bindings default)
(first (get-binding* key bindings (list default))))

3
collects/web-server/configuration/responders.rkt
View File

@ -23,8 +23,7 @@
"<unknown location>")))))
(define-runtime-path default-error-style-sheet
(list 'lib
"web-server/default-web-root/htdocs/error.css"))
"../default-web-root/htdocs/error.css")
(define (pretty-exception-response url exn)
(response/xexpr

3
collects/web-server/default-web-root/htdocs/servlets/examples/quiz.rkt
View File

@ -17,8 +17,7 @@
racket/file
(for-syntax racket/base))
(define-runtime-path *data-file*
(list 'lib
"web-server/default-web-root/htdocs/servlets/examples/english-measure-questions.rkt"))
"english-measure-questions.rkt")
(define *questions-per-quiz* 5)
(require web-server/servlet

11
collects/web-server/private/configure.rkt
View File

@ -9,7 +9,12 @@
make-directory*)
web-server/configuration/configuration-table-structs
web-server/configuration/configuration-table
web-server/private/util)
web-server/private/util
racket/runtime-path)
(define-runtime-path default-web-root
"../default-web-root")
(provide
interface-version timeout
start)
@ -710,7 +715,7 @@
(build-path (build-path-unless-absolute root (paths-servlet paths)) "servlets")])
(ensure-config-servlet configuration-path servlets-path)
(let ([defaults (build-path "Defaults")])
(ensure* (collection-path "web-server" "default-web-root" "htdocs")
(ensure* (build-path default-web-root "htdocs")
(build-path-unless-absolute root (paths-htdocs paths))
defaults))))
@ -736,7 +741,7 @@
(ensure-directory-shallow (build-path-unless-absolute host-base (paths-servlet paths)))
(let* ([messages (host-table-messages host)]
; more here maybe - check default config file instead? maybe not
[from-conf (collection-path "web-server" "default-web-root" "conf")]
[from-conf (build-path default-web-root "conf")]
[copy-conf
(lambda (from to)
(let ([to-path (build-path-unless-absolute conf to)])

4
collects/web-server/servlet-env.rkt
View File

@ -37,9 +37,7 @@
(div ([class "title"]) "Server Stopped")
(p "Return to DrRacket."))))))))
(define-runtime-path default-web-root
(list 'lib
"web-server/default-web-root"))
(define-runtime-path default-web-root "default-web-root")
(provide/contract
[serve/servlet (((request? . -> . can-be-response?))