Permalink
Browse files

- renamed the main current- procedure parameters to default-;

  - changed the way the default- parameters work: if a controller is created with an appropriate keyword (e.g. #:access-proc), the procedure is stored in the controller struct and does not change... otherwise, #f is stored in the controller and Dispatch always delegates to the default- parameter;
  - added enum-arg;
  - added default-controller-wrapper and set it to (if (access?) (body) (denied)), where each expr is either stored in the controller or is a parameter.
  • Loading branch information...
1 parent 8bac435 commit 7c7728dc3aff9986086ae377bfba66439759e1dc @davegurnell davegurnell committed Aug 26, 2009
Showing with 207 additions and 137 deletions.
  1. +19 −18 all-dispatch-tests.ss
  2. +22 −2 arg.ss
  3. +17 −11 codec.ss
  4. +48 −43 core.ss
  5. +45 −20 define-controller.ss
  6. +35 −24 define-site.ss
  7. +7 −5 main.ss
  8. +9 −9 response.ss
  9. +5 −5 test-base.ss
View
37 all-dispatch-tests.ss
@@ -52,15 +52,15 @@
(test-case "site-dispatch : controller undefined"
(check-pred response/full? (site-dispatch math (test-request "/subtract/1/2")))
- (parameterize ([current-controller-undefined-responder
+ (parameterize ([default-controller-undefined-responder
(lambda (controller request . args)
(cons (controller-id controller) args))])
(check-equal? (site-dispatch math (test-request "/subtract/1/2"))
'(subtract-numbers 1 2))))
(test-case "site-dispatch : access denied"
(check-pred response/full? (site-dispatch math (test-request "/divide/8/0")))
- (parameterize ([current-access-denied-responder
+ (parameterize ([default-access-denied-responder
(lambda (controller request . args)
(cons (controller-id controller) args))])
(check-equal? (site-dispatch math (test-request "/divide/8/0"))
@@ -82,11 +82,11 @@
(check-equal? (controller-url add-numbers 1 2) "/add/1/2"))
(test-case "controller-access? : divide-numbers"
- (check-true (controller-access? divide-numbers 8 2))
- (check-false (controller-access? divide-numbers 8 0)))
+ (check-true (controller-access? divide-numbers (test-request "foo") 8 2))
+ (check-false (controller-access? divide-numbers (test-request "foo") 8 0)))
(test-case "controller-link : no arguments"
- (let* ([link-ref (cut controller-link divide-numbers 8 4)]
+ (let* ([link-ref (cut controller-link divide-numbers (test-request "foo") 8 4)]
[mirrors (link-ref)]
[sexp (parameterize ([current-link-format 'sexp]) (link-ref))]
[sexps (parameterize ([current-link-format 'sexps]) (link-ref))])
@@ -97,12 +97,13 @@
(test-case "controller-link : all arguments"
(let* ([link-ref (lambda (body)
- (controller-link divide-numbers
- 8 4
- #:id 'id
- #:class 'class
- #:title "title"
- #:body body))]
+ (controller-link
+ divide-numbers
+ (test-request "foo") 8 4
+ #:id 'id
+ #:class 'class
+ #:title "title"
+ #:body body))]
[mirrors (link-ref "body")]
[sexp (parameterize ([current-link-format 'sexp]) (link-ref "body"))]
[sexps (parameterize ([current-link-format 'sexps]) (link-ref '("body")))])
@@ -112,7 +113,7 @@
(check-equal? sexps '((a ([href "/divide/8/4"] [id "id"] [class "class"] [title "title"]) "body")))))
(test-case "controller-link : no access : hide"
- (let* ([link-ref (cut controller-link divide-numbers 8 0)]
+ (let* ([link-ref (cut controller-link divide-numbers (test-request "foo") 8 0)]
[mirrors (link-ref)]
[sexp (parameterize ([current-link-format 'sexp]) (link-ref))]
[sexps (parameterize ([current-link-format 'sexps]) (link-ref))])
@@ -122,7 +123,7 @@
(check-equal? sexps null)))
(test-case "controller-link : no access : span"
- (let* ([link-ref (cut controller-link divide-numbers 8 0 #:no-access 'span #:id 'id #:class 'class #:title "title")]
+ (let* ([link-ref (cut controller-link divide-numbers (test-request "foo") 8 0 #:no-access 'span #:id 'id #:class 'class #:title "title")]
[mirrors (link-ref)]
[sexp (parameterize ([current-link-format 'sexp]) (link-ref))]
[sexps (parameterize ([current-link-format 'sexps]) (link-ref))])
@@ -132,7 +133,7 @@
(check-equal? sexps '((span ([id "id"] [class "no-access-link class"] [title "title"]) "/divide/8/0")))))
(test-case "controller-link : no access : body"
- (let* ([link-ref (cut controller-link divide-numbers 8 0 #:no-access 'body)]
+ (let* ([link-ref (cut controller-link divide-numbers (test-request "foo") 8 0 #:no-access 'body)]
[mirrors (link-ref)]
[sexp (parameterize ([current-link-format 'sexp]) (link-ref))]
[sexps (parameterize ([current-link-format 'sexps]) (link-ref))])
@@ -149,10 +150,10 @@
and-booleans
time-after))
- (test-case "current-controller-wrapper"
- (parameterize ([current-controller-wrapper
- (lambda (continue controller request . args)
- (add1 (apply continue controller request args)))])
+ (test-case "default-controller-wrapper"
+ (parameterize ([default-controller-wrapper
+ (lambda (controller request . args)
+ (add1 (apply (controller-body-proc controller) request args)))])
(check-equal? (site-dispatch math (test-request "/divide/8/2")) 5)))
(test-case "boolean-arg"
View
24 arg.ss
@@ -3,8 +3,9 @@
(require "base.ss")
(require net/uri-codec
+ scheme/string
srfi/19
- (unlib-in time)
+ (unlib-in enumeration time)
"core.ss")
; -> arg
@@ -87,6 +88,24 @@
(uri-encode arg)
(raise-type-error 'rest-arg "string" arg)))))
+; enum -> arg
+(define (enum-arg enum)
+ (make-arg
+ (string-join (map regexp-quote
+ (map (cut format "~a" <>)
+ (enum-values enum)))
+ "|")
+ (lambda (raw)
+ (for/or ([val (in-list (enum-values enum))])
+ (and (equal? (format "~a" val) raw) val)))
+ (lambda (val)
+ (if (enum-value? enum val)
+ val
+ (raise-type-error
+ (enum-name enum)
+ (format "~a" (enum-values enum))
+ val)))))
+
; Helpers ----------------------------------------
(define (safe-string->date str fmt)
@@ -102,4 +121,5 @@
[string-arg (-> arg?)]
[symbol-arg (-> arg?)]
[time-utc-arg (-> string? arg?)]
- [rest-arg (-> arg?)])
+ [rest-arg (-> arg?)]
+ [enum-arg (-> enum? arg?)])
View
28 codec.ss
@@ -12,7 +12,9 @@
(let ([url-string (clean-request-url request)])
(match-let ([(list-rest controller args) (site-decode site url-string)])
(if controller
- (apply controller request args)
+ (if (controller-requestless? controller)
+ (apply controller args)
+ (apply controller request args))
(raise-exn exn:dispatch (format "no rule for url: ~a" url-string))))))
; controller any ... -> boolean
@@ -21,9 +23,10 @@
; controller any ... -> string
(define (controller-url controller . args)
- (for/or ([rule (in-list (site-rules (controller-site controller)))])
- (and (eq? (rule-controller rule) controller)
- (pattern-encode (rule-pattern rule) args))))
+ (or (for/or ([rule (in-list (site-rules (controller-site controller)))])
+ (and (eq? (rule-controller rule) controller)
+ (pattern-encode (rule-pattern rule) args)))
+ (error "no url for controller" (cons controller args))))
; controller
; [#:body (U xml sexp #f)]
@@ -45,13 +48,16 @@
#:format [link-format (current-link-format)]
#:no-access [substitute 'hide]
. args)
- (let* ([access? (apply controller-access? controller args)]
- [href (apply controller-url controller args)]
- [body (cond [body body]
- [(eq? link-format 'sexps) (list href)]
- [else href])]
- [id (and id (string+symbol->string id))]
- [class (and (pair? classes) (string-join (map string+symbol->string classes) " "))])
+ (let* ([requestless? (controller-requestless? controller)]
+ [access? (apply controller-access? controller args)]
+ [href (if (controller-requestless? controller)
+ (apply controller-url controller args)
+ (apply controller-url controller (cdr args)))]
+ [body (cond [body body]
+ [(eq? link-format 'sexps) (list href)]
+ [else href])]
+ [id (and id (string+symbol->string id))]
+ [class (and (pair? classes) (string-join (map string+symbol->string classes) " "))])
(if access?
(enum-case dispatch-link-formats link-format
[(mirrors) (xml (a (@ [href ,href]
View
91 core.ss
@@ -10,7 +10,7 @@
; Struct types -----------------------------------
(define-struct site
- (id rules)
+ (id rules controllers)
#:property
prop:custom-write
(lambda (site out write?)
@@ -22,9 +22,11 @@
(define-struct controller
(id
[site #:mutable]
+ [wrapper-proc #:mutable]
[body-proc #:mutable]
[access-proc #:mutable]
- [access-denied-proc #:mutable])
+ [access-denied-proc #:mutable]
+ [requestless? #:mutable])
#:property
prop:custom-write
(lambda (controller out write?)
@@ -33,16 +35,8 @@
out))
#:property
prop:procedure
- (lambda (controller request . args)
- (apply
- (current-controller-wrapper)
- (lambda (controller request . args)
- (if (apply (controller-access-proc controller) args)
- (apply (controller-body-proc controller) request args)
- (apply (controller-access-denied-proc controller) request args)))
- controller
- request
- args))
+ (lambda (controller . args)
+ (apply (controller-wrapper-proc controller) args))
#:transparent)
; (struct string (string -> any) (any -> string))
@@ -58,28 +52,22 @@
; symbol -> controller
(define (create-controller id)
- (letrec ([ans (make-controller
- id
- #f
- (lambda (request . args)
- (apply (current-controller-undefined-responder) ans request args))
- (lambda _ #t)
- (lambda (request . args)
- (apply (current-access-denied-responder) ans request args)))])
- ans))
+ (letrec ([controller (make-controller
+ id
+ #f
+ (lambda args (apply (default-controller-wrapper) controller args))
+ (lambda args (apply (default-controller-undefined-responder) controller args))
+ (lambda args (apply (default-access-predicate) controller args))
+ (lambda args (apply (default-access-denied-responder) controller args))
+ (requestless-controllers?))])
+ controller))
; (U string arg) ... -> pattern
(define (create-pattern . elements)
(make-pattern (make-regexp-maker elements)
(filter arg? elements)
elements))
-; Accessors ------------------------------------
-
-; site -> (listof controller)
-(define (site-controllers site)
- (remove-duplicates (map rule-controller (site-rules site))))
-
; Configuration --------------------------------
(define-enum dispatch-link-formats (mirrors sexp sexps))
@@ -89,22 +77,35 @@
(define current-link-format
(make-parameter (dispatch-link-formats mirrors)))
-; (parameter (controller request any ... -> response))
+; (parameter boolean)
+(define requestless-controllers?
+ (make-parameter #f))
+
+; (parameter (any ... -> boolean))
+; Initialised in response.ss.
+(define default-access-predicate
+ (make-parameter (lambda _ #t)))
+
+; (parameter (controller any ... -> response))
; Initialised in response.ss.
-(define current-access-denied-responder
+(define default-access-denied-responder
(make-parameter (lambda _ (error "not initialised"))))
-; (parameter (controller request any ... -> response))
+; (parameter (controller any ... -> response))
; Initialised in response.ss.
-(define current-controller-undefined-responder
+(define default-controller-undefined-responder
(make-parameter (lambda _ (error "not initialised"))))
-; (parameter ((controller request any ... -> any)
-; controller request any ... -> any))
+; (parameter ((any ... -> any) any ... -> any))
; Initialised in response.ss.
-(define current-controller-wrapper
- (make-parameter (lambda (continue controller request . args)
- (apply continue controller request args))))
+(define default-controller-wrapper
+ (make-parameter
+ (let ([initial-controller-wrapper
+ (lambda (controller . args)
+ (if (apply (controller-access-proc controller) args)
+ (apply (controller-body-proc controller) args)
+ (apply (controller-access-denied-proc controller) args)))])
+ initial-controller-wrapper)))
; Helpers ----------------------------------------
@@ -115,7 +116,7 @@
[(? string?) (string-append "\\/" (regexp-quote elem))]
[(? arg?) (string-append "\\/(" (arg-pattern elem) ")")]
[(? procedure?) (lambda () (string-append "\\/" (regexp-quote (elem))))]))
- "\\/?$")]) ; optional trailing slash
+ "\\/?$")]) ; optional trailing slash
(lambda ()
(pregexp (apply string-append
(for/list ([part (in-list parts)])
@@ -130,12 +131,15 @@
(provide/contract
[struct site ([id symbol?]
- [rules (listof rule?)])]
+ [rules (listof rule?)]
+ [controllers (listof controller?)])]
[struct controller ([id symbol?]
[site site?]
+ [wrapper-proc (or/c procedure? #f)]
[body-proc procedure?]
[access-proc procedure?]
- [access-denied-proc procedure?])]
+ [access-denied-proc procedure?]
+ [requestless? boolean?])]
[struct arg ([pattern string?]
[decoder procedure?]
[encoder procedure?])]
@@ -146,8 +150,9 @@
[controller controller?])]
[create-controller (-> symbol? controller?)]
[create-pattern (->* () () #:rest (listof (or/c string? arg? procedure?)) pattern?)]
- [site-controllers (-> site? (listof controller?))]
[current-link-format (parameter/c (or/c 'mirrors 'sexp 'sexps))]
- [current-controller-undefined-responder (parameter/c (->* (controller? request?) () #:rest any/c any))]
- [current-access-denied-responder (parameter/c (->* (controller? request?) () #:rest any/c any))]
- [current-controller-wrapper (parameter/c (->* (procedure? controller? request?) () #:rest any/c any))])
+ [requestless-controllers? (parameter/c boolean?)]
+ [default-controller-wrapper (parameter/c procedure?)]
+ [default-access-predicate (parameter/c procedure?)]
+ [default-access-denied-responder (parameter/c procedure?)]
+ [default-controller-undefined-responder (parameter/c procedure?)])
View
65 define-controller.ss
@@ -10,41 +10,66 @@
(define-syntax (define-controller complete-stx)
- (define id-stx #f)
- (define request-stx #f)
- (define args-stx #f)
- (define rest-stx #f)
- (define access-expr-stx #'#t)
+ (define id-stx #f)
+ (define args-stx #f)
+ (define rest-stx #f)
+ (define wrapper-proc-stx #'#f)
+ (define access-proc-stx #'#f)
+ (define denied-proc-stx #'#f)
+ (define requestless-stx #'(void))
(define (parse-keywords stx)
(syntax-case stx ()
+ [(#:wrapper-proc proc other ...)
+ (begin (set! wrapper-proc-stx #'proc)
+ (parse-keywords #'(other ...)))]
[(#:access? expr other ...)
- (begin (set! access-expr-stx #'expr)
+ (begin (set! access-proc-stx
+ (with-syntax ([(arg ...) args-stx])
+ #'(lambda (arg ...) expr)))
+ (parse-keywords #'(other ...)))]
+ [(#:access-proc proc other ...)
+ (begin (set! access-proc-stx #'proc)
+ (parse-keywords #'(other ...)))]
+ [(#:denied-proc proc other ...)
+ (begin (set! denied-proc-stx #'proc)
+ (parse-keywords #'(other ...)))]
+ [(#:requestless? val other ...)
+ (begin (set! requestless-stx #'val)
(parse-keywords #'(other ...)))]
[rest (parse-body #'rest)]))
(define (parse-body body-stx)
(with-syntax ([id id-stx]
- [access-id (make-id id-stx id-stx '-access?)]
+ [(arg ...) args-stx]
[(expr ...) body-stx]
- [access-expr access-expr-stx]
- [(arg ...) args-stx])
+ [body-id (make-id id-stx id-stx '-body)]
+ [access-id (make-id id-stx id-stx '-access?)]
+ [denied-id (make-id id-stx id-stx '-access-denied)]
+ [wrapper-id (make-id id-stx id-stx '-wrapper)]
+ [requestless-id (make-id id-stx id-stx '-requestless?)]
+ [wrapper-proc wrapper-proc-stx]
+ [access-proc access-proc-stx]
+ [denied-proc denied-proc-stx]
+ [requestless? requestless-stx])
(quasisyntax/loc complete-stx
- (begin (set-controller-body-proc!
- id
- (let ([id (lambda (request arg ...) expr ...)])
- id))
- (set-controller-access-proc!
- id
- (let ([access-id (lambda (arg ...) access-expr)])
- access-id))))))
+ (let ([body-id (lambda (arg ...) expr ...)]
+ [wrapper-id wrapper-proc]
+ [access-id access-proc]
+ [denied-id denied-proc]
+ [requestless-id requestless?])
+ (set-controller-body-proc! id body-id)
+ (when wrapper-id (set-controller-wrapper-proc! id wrapper-id))
+ (when access-id (set-controller-access-proc! id access-id))
+ (when denied-id (set-controller-access-denied-proc! id denied-id))
+ (unless (void? requestless-id)
+ (set-controller-requestless?! id requestless-id))))))
(syntax-case complete-stx ()
- [(_ (id request . args) keyword+expr ...)
+ [(_ (id arg ...) keyword+expr ...)
(identifier? #'id)
(begin (set! id-stx #'id)
- (set! request-stx #'request)
- (set! args-stx #'args)
+ (set! args-stx #'(arg ...))
(parse-keywords #'(keyword+expr ...)))]))
; Provide statements -----------------------------
View
59 define-site.ss
@@ -1,31 +1,33 @@
#lang scheme/base
-(require (for-syntax scheme/base)
- "base.ss"
- (for-template "base.ss"))
+(require "base.ss")
-(require (for-syntax scheme/provide-transform
+(require (for-syntax scheme/base
+ scheme/list
+ scheme/provide-transform
+ (unlib-in syntax)
"syntax-info.ss")
- "core.ss")
+ "core.ss"
+ (for-template "base.ss"))
(require (for-syntax (unlib-in syntax)))
(define-syntax (define-site complete-stx)
- (define site-stx #f) ; site
- (define controller-stxs null) ; in reverse order ...
- (define rule-stxs null) ; in reverse order ...
+ (define id-stx #f) ; id
+ (define controller-stxs null) ; in reverse order ...
+ (define rule-stxs null) ; in reverse order ...
(define (parse-identifier stx)
(syntax-case stx ()
- [(site rule ...)
- (begin (set! site-stx #'site)
- (parse-rules #'(rule ...)))]))
+ [(id (rule ...) kw ...)
+ (begin (set! id-stx #'id)
+ (parse-rules #'((rule ...) kw ...)))]))
(define (parse-rules stx)
(syntax-case stx ()
- [() (parse-finish)]
- [(rule rest ...) (parse-rule #'rule #'(rest ...))]))
+ [(() kw ...) (parse-keywords #'(kw ...))]
+ [((rule rest ...) kw ...) (parse-rule #'rule #'((rest ...) kw ...))]))
(define (parse-rule rule-stx other-stx)
(syntax-case rule-stx ()
@@ -35,35 +37,44 @@
(set! controller-stxs (cons #'controller controller-stxs))
(parse-rules other-stx))]))
+ (define (parse-keywords stx)
+ (syntax-case stx ()
+ [() (parse-finish)]
+ [(#:other-controllers (id ...) rest ...)
+ (if (andmap identifier? (syntax->list #'(id ...)))
+ (begin (set! controller-stxs (append (reverse (syntax->list #'(id ...))) controller-stxs))
+ (parse-keywords #'(rest ...)))
+ (raise-syntax-error #f "#:other-controllers must be a list of identifiers" #'(id ...) complete-stx))]))
+
(define (parse-finish)
- (with-syntax ([site-private (make-id #f site-stx)]
- [site site-stx]
- [(controller ...) (reverse controller-stxs)]
+ (with-syntax ([id-private (make-id #f id-stx)]
+ [id id-stx]
+ [(controller ...) (remove-duplicates (reverse controller-stxs) symbolic-identifier=?)]
[(rule ...) (reverse rule-stxs)])
(syntax/loc complete-stx
(begin
(define controller (create-controller 'controller))
...
- (define site-private
- (make-site 'site (list rule ...)))
+ (define id-private
+ (make-site 'id (list rule ...) (list controller ...)))
- (set-controller-site! controller site-private)
+ (set-controller-site! controller id-private)
...
- (define-syntax site
+ (define-syntax id
(let ([certify (syntax-local-certifier #t)])
(site-info-add!
(make-site-info
- (certify #'site)
- (certify #'site-private)
+ (certify #'id)
+ (certify #'id-private)
(list (certify #'controller) ...)))))))))
(syntax-case complete-stx ()
- [(_ id rule ...)
+ [(_ id (rule ...) kw ...)
(identifier? #'id)
- (parse-identifier #'(id rule ...))]))
+ (parse-identifier #'(id (rule ...) kw ...))]))
; (_ id)
(define-syntax site-out
View
12 main.ss
@@ -24,13 +24,15 @@
controller-link
controller?
current-link-format
- current-controller-undefined-responder
- current-access-denied-responder
- current-controller-wrapper
-
+ requestless-controllers?
+ default-controller-wrapper
+ default-controller-undefined-responder
+ default-access-denied-responder
+
boolean-arg
time-utc-arg
integer-arg
number-arg
string-arg
- symbol-arg)
+ symbol-arg
+ enum-arg)
View
18 response.ss
@@ -3,14 +3,13 @@
(require "base.ss")
(require (mirrors-in)
- "codec.ss"
"core.ss")
; Procedures -------------------------------------
-; controller request any ... -> response
-(current-controller-undefined-responder
- (lambda (controller request . args)
+; controller any ... -> response
+(default-controller-undefined-responder
+ (lambda (controller . args)
(make-html-response
#:code 500
#:message "Internal error"
@@ -21,17 +20,19 @@
(p (@ [class "example"])
(span (@ [class "paren"]) "(")
(span (@ [class "controller"]) ,(controller-id controller))
- ,@(for/list ([arg (in-list (cons 'request args))])
+ ,@(for/list ([arg (in-list (if (controller-requestless? controller)
+ args
+ (cons 'request args)))])
(xml (span (@ [class "argument"]) ,(format " ~s" arg))))
(span (@ [class "paren"]) ")"))
(p "Unfortunately, it looks like this controller has not been defined with a "
(span (@ [class "controller"]) "define-controller") " statement.")
(p "If you have written a definition for this controller, make sure it is "
"directly or indirectly required by the main module that runs your application."))))))))
-; controller request any ... -> response
-(current-access-denied-responder
- (lambda (controller request . args)
+; controller any ... -> response
+(default-access-denied-responder
+ (lambda (controller . args)
(make-html-response
#:code 403
#:message "Access denied"
@@ -56,4 +57,3 @@ p { font-family: arial,sans-serif; }
.argument { font-family: monaco,monospace; color: #070; }
ENDCSS
)))
-
View
10 test-base.ss
@@ -8,11 +8,11 @@
; Test data --------------------------------------
(define-site math
- [("divide" (integer-arg) (integer-arg)) divide-numbers]
- [("add" (integer-arg) (integer-arg)) add-numbers]
- [("subtract" (integer-arg) (integer-arg)) subtract-numbers]
- [("and" (boolean-arg) (boolean-arg)) and-booleans]
- [("after" (time-utc-arg "~Y~m~d") (time-utc-arg "~Y~m~d")) time-after])
+ ([("divide" (integer-arg) (integer-arg)) divide-numbers]
+ [("add" (integer-arg) (integer-arg)) add-numbers]
+ [("subtract" (integer-arg) (integer-arg)) subtract-numbers]
+ [("and" (boolean-arg) (boolean-arg)) and-booleans]
+ [("after" (time-utc-arg "~Y~m~d") (time-utc-arg "~Y~m~d")) time-after]))
; Provide statements -----------------------------

0 comments on commit 7c7728d

Please sign in to comment.