Skip to content

Commit

Permalink
- removed requestless-controllers? parameter, replaced by #:requestl…
Browse files Browse the repository at this point in the history 
…ess? argument to define-site;

  - renamed dispatch-link-format and dispatch-link-substitute to default-link-format and default-link-substitute;
  - changed default value of default-link-substitute to 'body;
  - fixed bug in arg->raw procedure of enum-arg.
  • Loading branch information
Dave Gurnell committed Aug 29, 2009
1 parent be15cc8 commit 238fdc7
Show file tree
Hide file tree
Showing 6 changed files with 111 additions and 92 deletions.
7 changes: 2 additions & 5 deletions arg.ss
View file
Expand Up @@ -100,11 +100,8 @@
(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)))))
(format "~a" val)
(raise-type-error (enum-name enum) (format "~a" (enum-values enum)) val)))))

; Helpers ----------------------------------------

Expand Down
100 changes: 50 additions & 50 deletions codec.ss
View file
Expand Up @@ -15,7 +15,7 @@
(if (controller-requestless? controller)
(apply controller args)
(apply controller request args))
(raise-exn exn:dispatch (format "no rule for url: ~a" url-string))))))
((site-not-found-proc site) request)))))

; controller any ... -> boolean
(define (controller-access? controller . args)
Expand All @@ -34,8 +34,8 @@
; [#:class (U string symbol #f)]
; [#:classes (listof (U string symbol))]
; [#:title (U string #f)]
; [#:format (U 'mirrors 'sexp 'sexps)]
; [#:no-access (U 'hide 'span 'body)]
; [#:format link-format]
; [#:no-access link-substitute]
; ->
; (U xml sexp (listof sexp))
(define (controller-link
Expand All @@ -45,52 +45,52 @@
#:class [class #f]
#:classes [classes (if class (list class) null)]
#:title [title #f]
#:format [link-format (current-link-format)]
#:no-access [substitute 'hide]
#:format [link-format (default-link-format)]
#:no-access [substitute (default-link-substitute)]
. args)
(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]
,(opt-xml-attr id)
,(opt-xml-attr class)
,(opt-xml-attr title)) ,body))]
[(sexp) `(a ([href ,href]
,@(opt-attr-list id)
,@(opt-attr-list class)
,@(opt-attr-list title)) ,body)]
[(sexps) `((a ([href ,href]
,@(opt-attr-list id)
,@(opt-attr-list class)
,@(opt-attr-list title)) ,@body))])
(enum-case dispatch-link-formats link-format
[(mirrors) (enum-case dispatch-link-substitutes substitute
[(hide) (xml)]
[(span) (xml (span (@ ,(opt-xml-attr id)
,(opt-xml-attr class class (format "no-access-link ~a" class))
,(opt-xml-attr title)) ,body))]
[(body) (xml ,body)])]
[(sexp) (enum-case dispatch-link-substitutes substitute
[(hide) '(span)]
[(span) `(span (,@(opt-attr-list id)
,@(opt-attr-list class class (format "no-access-link ~a" class))
,@(opt-attr-list title)) ,body)]
[(body) body])]
[(sexps) (enum-case dispatch-link-substitutes substitute
[(hide) null]
[(span) `((span (,@(opt-attr-list id)
,@(opt-attr-list class class (format "no-access-link ~a" class))
,@(opt-attr-list title)) ,@body))]
[(body) body])]))))
(begin0 (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 link-formats link-format
[(mirrors) (xml (a (@ [href ,href]
,(opt-xml-attr id)
,(opt-xml-attr class)
,(opt-xml-attr title)) ,body))]
[(sexp) `(a ([href ,href]
,@(opt-attr-list id)
,@(opt-attr-list class)
,@(opt-attr-list title)) ,body)]
[(sexps) `((a ([href ,href]
,@(opt-attr-list id)
,@(opt-attr-list class)
,@(opt-attr-list title)) ,@body))])
(enum-case link-formats link-format
[(mirrors) (enum-case link-substitutes substitute
[(hide) (xml)]
[(span) (xml (span (@ ,(opt-xml-attr id)
,(opt-xml-attr class class (format "no-access-link ~a" class))
,(opt-xml-attr title)) ,body))]
[(body) (xml ,body)])]
[(sexp) (enum-case link-substitutes substitute
[(hide) '(span)]
[(span) `(span (,@(opt-attr-list id)
,@(opt-attr-list class class (format "no-access-link ~a" class))
,@(opt-attr-list title)) ,body)]
[(body) body])]
[(sexps) (enum-case link-substitutes substitute
[(hide) null]
[(span) `((span (,@(opt-attr-list id)
,@(opt-attr-list class class (format "no-access-link ~a" class))
,@(opt-attr-list title)) ,@body))]
[(body) body])])))))

; Patterns ---------------------------------------

Expand Down Expand Up @@ -159,7 +159,7 @@
#:class (or/c symbol? string? #f)
#:classes (listof (or/c symbol? string?))
#:title (or/c string? #f)
#:format (cut enum-value? dispatch-link-formats <>)
#:no-access (cut enum-value? dispatch-link-substitutes <>))
#:format (cut enum-value? link-formats <>)
#:no-access (cut enum-value? link-substitutes <>))
#:rest any/c
any)])
56 changes: 29 additions & 27 deletions core.ss
View file
Expand Up @@ -10,7 +10,7 @@
; Struct types -----------------------------------

(define-struct site
(id rules controllers)
(id rules controllers not-found-proc)
#:property
prop:custom-write
(lambda (site out write?)
Expand All @@ -36,7 +36,7 @@
#:property
prop:procedure
(lambda (controller . args)
(apply (controller-wrapper-proc controller) args))
(apply (controller-wrapper-proc controller) controller args))
#:transparent)

; (struct string (string -> any) (any -> string))
Expand All @@ -50,16 +50,16 @@

; Constructors -----------------------------------

; symbol -> controller
(define (create-controller id)
; symbol boolean -> controller
(define (create-controller id requestless?)
(letrec ([controller (make-controller
id
#f
(lambda args (apply (default-controller-wrapper) controller args))
(lambda (controller . 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?))])
requestless?)])
controller))

; (U string arg) ... -> pattern
Expand All @@ -70,27 +70,27 @@

; Configuration --------------------------------

(define-enum dispatch-link-formats (mirrors sexp sexps))
(define-enum dispatch-link-substitutes (hide span body))
(define-enum link-formats (mirrors sexp sexps))
(define-enum link-substitutes (hide span body))

; (parameter dispatch-link-format)
(define current-link-format
(make-parameter (dispatch-link-formats mirrors)))
; (parameter link-format)
(define default-link-format
(make-parameter (link-formats mirrors)))

; (parameter boolean)
(define requestless-controllers?
(make-parameter #f))
; (parameter link-format)
(define default-link-substitute
(make-parameter (link-substitutes body)))

; controller any ... -> any
(define (plain-controller-wrapper controller . args)
(if (apply (controller-access-proc controller) args)
(apply (controller-body-proc controller) args)
(apply (controller-access-denied-proc controller) args)))

; (parameter ((any ... -> any) any ... -> any))
; Initialised in response.ss.
(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)))
(make-parameter plain-controller-wrapper))

; (parameter (any ... -> boolean))
; Initialised in response.ss.
Expand Down Expand Up @@ -127,13 +127,14 @@

; Provide statements -----------------------------

(provide dispatch-link-formats
dispatch-link-substitutes)
(provide link-formats
link-substitutes)

(provide/contract
[struct site ([id symbol?]
[rules (listof rule?)]
[controllers (listof controller?)])]
[controllers (listof controller?)]
[not-found-proc (-> request? response/c)])]
[struct controller ([id symbol?]
[site site?]
[wrapper-proc (or/c procedure? #f)]
Expand All @@ -149,10 +150,11 @@
[elements (listof (or/c string? procedure? arg?))])]
[struct rule ([pattern pattern?]
[controller controller?])]
[create-controller (-> symbol? controller?)]
[create-controller (-> symbol? boolean? controller?)]
[create-pattern (->* () () #:rest (listof (or/c string? arg? procedure?)) pattern?)]
[current-link-format (parameter/c (or/c 'mirrors 'sexp 'sexps))]
[requestless-controllers? (parameter/c boolean?)]
[default-link-format (parameter/c (enum-value/c link-formats))]
[default-link-substitute (parameter/c (enum-value/c link-substitutes))]
[plain-controller-wrapper (->* (controller?) () #:rest any/c any)]
[default-controller-wrapper (parameter/c procedure?)]
[default-access-predicate (parameter/c procedure?)]
[default-access-denied-responder (parameter/c procedure?)]
Expand Down
5 changes: 3 additions & 2 deletions define-controller.ss
View file
Expand Up @@ -16,7 +16,7 @@
(define wrapper-proc-stx #'#f)
(define access-proc-stx #'#f)
(define denied-proc-stx #'#f)
(define requestless-stx #'(requestless-controllers?))
(define requestless-stx #'(void))

(define (parse-keywords stx)
(syntax-case stx ()
Expand Down Expand Up @@ -65,7 +65,8 @@
(set-controller-access-proc! id access-id))
(when denied-id
(set-controller-access-denied-proc! id denied-id))
(set-controller-requestless?! id requestless-id)))))
(when (not (void? requestless-id))
(set-controller-requestless?! id requestless-id))))))

(syntax-case complete-stx ()
[(_ (id arg ...) keyword+expr ...)
Expand Down
27 changes: 21 additions & 6 deletions define-site.ss
View file
Expand Up @@ -7,16 +7,17 @@
scheme/provide-transform
(unlib-in syntax)
"syntax-info.ss")
web-server/dispatchers/dispatch
"core.ss"
(for-template "base.ss"))

(require (for-syntax (unlib-in syntax)))

(define-syntax (define-site complete-stx)

(define id-stx #f) ; id
(define id-stx #f) ; id
(define controller-stxs null) ; in reverse order ...
(define rule-stxs null) ; in reverse order ...
(define requestless-stx #'#f)
(define not-found-stx #'(lambda (request) (next-dispatcher)))

(define (parse-identifier stx)
(syntax-case stx ()
Expand All @@ -40,6 +41,12 @@
(define (parse-keywords stx)
(syntax-case stx ()
[() (parse-finish)]
[(#:requestless? val rest ...)
(begin (set! requestless-stx #'val)
(parse-keywords #'(rest ...)))]
[(#:not-found expr rest ...)
(begin (set! not-found-stx #'expr)
(parse-keywords #'(rest ...)))]
[(#:other-controllers (id ...) rest ...)
(if (andmap identifier? (syntax->list #'(id ...)))
(begin (set! controller-stxs (append (reverse (syntax->list #'(id ...))) controller-stxs))
Expand All @@ -50,15 +57,23 @@
(with-syntax ([id-private (make-id #f id-stx)]
[id id-stx]
[(controller ...) (remove-duplicates (reverse controller-stxs) symbolic-identifier=?)]
[(rule ...) (reverse rule-stxs)])
[(rule ...) (reverse rule-stxs)]
[requestless-expr requestless-stx]
[not-found-proc not-found-stx])
(syntax/loc complete-stx
(begin

(define controller (create-controller 'controller))
(define requestless? requestless-expr)

(define controller (create-controller 'controller requestless?))
...

(define id-private
(make-site 'id (list rule ...) (list controller ...)))
(make-site
'id
(list rule ...)
(list controller ...)
not-found-proc))

(set-controller-site! controller id-private)
...
Expand Down
8 changes: 6 additions & 2 deletions main.ss
View file
Expand Up @@ -15,8 +15,12 @@
(struct-out pattern)
(struct-out arg)
(struct-out controller)
current-link-format
requestless-controllers?
link-formats
link-substitutes
default-link-format
default-link-substitute

plain-controller-wrapper
default-controller-wrapper
default-access-predicate
default-controller-undefined-responder
Expand Down

0 comments on commit 238fdc7

Please sign in to comment.