From 42ca979abd7d29f65f2e924a7d89cb17c9406995 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 15 Aug 2008 20:07:12 +0000 Subject: [PATCH] Detecting the lack of a start proc svn: r11286 --- collects/web-server/insta/insta.ss | 55 +++++-- .../tutorial/examples/iteration-9s.ss | 139 ++++++++++++++++++ 2 files changed, 183 insertions(+), 11 deletions(-) create mode 100644 collects/web-server/scribblings/tutorial/examples/iteration-9s.ss diff --git a/collects/web-server/insta/insta.ss b/collects/web-server/insta/insta.ss index d5e675720b..3ba5356be7 100644 --- a/collects/web-server/insta/insta.ss +++ b/collects/web-server/insta/insta.ss @@ -1,6 +1,8 @@ #lang scheme (require web-server/servlet - web-server/servlet-env) + web-server/servlet-env + (for-syntax scheme) + (for-syntax syntax/kerncase)) (provide (all-from-out web-server/servlet) @@ -22,15 +24,46 @@ (define (no-web-browser) (set! launch-browser? false)) -(define-syntax (web-module-begin stx) +;; check-for-def : syntax syntax-list -> void +;; Expands body-stxs and determines if id-stx is bound therein. +;; If not error w/ error-msg. stx is the root syntax context for everything +(define-for-syntax (check-for-def stx id-stx error-msg body-stxs) + (with-syntax ([(pmb body ...) + (local-expand + (quasisyntax/loc stx + (#%module-begin #,@body-stxs)) + 'module-begin + empty)]) + (let loop ([syns (syntax->list #'(body ...))]) + (if (empty? syns) + (raise-syntax-error 'insta error-msg stx) + (kernel-syntax-case (first syns) #t + [(define-values (id ...) expr) + (unless + (ormap (lambda (id) + (and (identifier? id) + (free-identifier=? id id-stx))) + (syntax->list #'(id ...))) + (loop (rest syns))) + ] + [_ + (loop (rest syns))]))) + (quasisyntax/loc stx + (pmb body ...)))) + +(define-syntax (web-module-begin stx) (syntax-case stx () [(_ body ...) - #'(#%module-begin - body ... - (provide/contract (start (request? . -> . response?))) - (if extra-files-path - (serve/servlet start - #:extra-files-path extra-files-path - #:launch-browser? launch-browser?) - (serve/servlet start - #:launch-browser? launch-browser?)))])) \ No newline at end of file + (let* ([start (datum->syntax stx 'start)] + [expanded (check-for-def stx + start "You must provide a 'start' request handler." + #'(body ...))]) + (quasisyntax/loc stx + (#,@expanded + (provide/contract (#,start (request? . -> . response?))) + (if extra-files-path + (serve/servlet #,start + #:extra-files-path extra-files-path + #:launch-browser? launch-browser?) + (serve/servlet #,start + #:launch-browser? launch-browser?)))))])) \ No newline at end of file diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-9s.ss b/collects/web-server/scribblings/tutorial/examples/iteration-9s.ss new file mode 100644 index 0000000000..1c17dd4564 --- /dev/null +++ b/collects/web-server/scribblings/tutorial/examples/iteration-9s.ss @@ -0,0 +1,139 @@ +#lang web-server + +(require "model-2.ss") + +;; start: request -> html-response +;; Consumes a request and produces a page that displays +;; all of the web content. +(define (start request) + (render-blog-page + (initialize-blog! + (build-path (find-system-path 'home-dir) + "the-blog-data.db")) + request)) + +;; render-blog-page: blog request -> html-response +;; Produces an html-response page of the content of the +;; blog. +(define (render-blog-page a-blog request) + (define (response-generator make-url) + `(html (head (title "My Blog")) + (body + (h1 "My Blog") + ,(render-posts a-blog make-url) + (form ((action + ,(make-url insert-post-handler))) + (input ((name "title"))) + (input ((name "body"))) + (input ((type "submit"))))))) + + (define (insert-post-handler request) + (define bindings (request-bindings/raw request)) + (blog-insert-post! + a-blog + (bytes->string/utf-8 (bindings-assq #"title" bindings)) + (bytes->string/utf-8 (bindings-assq #"body" bindings))) + (render-blog-page a-blog (redirect/get))) + + (send/suspend/dispatch response-generator)) + +;; render-post-detail-page: post request -> html-response +;; Consumes a post and produces a detail page of the post. +;; The user will be able to either insert new comments +;; or go back to render-blog-page. +(define (render-post-detail-page a-blog a-post request) + (define (response-generator make-url) + `(html (head (title "Post Details")) + (body + (h1 "Post Details") + (h2 ,(post-title a-post)) + (p ,(post-body a-post)) + ,(render-as-itemized-list + (post-comments a-post)) + (form ((action + ,(make-url insert-comment-handler))) + (input ((name "comment"))) + (input ((type "submit")))) + (a ((href ,(make-url back-handler))) + "Back to the blog")))) + + (define (parse-comment bindings) + (bytes->string/utf-8 (bindings-assq #"comment" bindings))) + + (define (insert-comment-handler request) + (render-confirm-add-comment-page + a-blog + (parse-comment (request-bindings/raw request)) + a-post + request)) + + (define (back-handler request) + (render-blog-page a-blog request)) + + (send/suspend/dispatch response-generator)) + +;; render-confirm-add-comment-page : +;; blog comment post request -> html-response +;; Consumes a comment that we intend to add to a post, as well +;; as the request. If the user follows through, adds a comment +;; and goes back to the display page. Otherwise, goes back to +;; the detail page of the post. +(define (render-confirm-add-comment-page a-blog a-comment + a-post request) + (define (response-generator make-url) + `(html (head (title "Add a Comment")) + (body + (h1 "Add a Comment") + "The comment: " (div (p ,a-comment)) + "will be added to " + (div ,(post-title a-post)) + + (p (a ((href ,(make-url yes-handler))) + "Yes, add the comment.")) + (p (a ((href ,(make-url cancel-handler))) + "No, I changed my mind!"))))) + + (define (yes-handler request) + (post-insert-comment! a-blog a-post a-comment) + (render-post-detail-page a-blog a-post (redirect/get))) + + (define (cancel-handler request) + (render-post-detail-page a-blog a-post request)) + + (send/suspend/dispatch response-generator)) + +;; render-post: post (handler -> string) -> html-response +;; Consumes a post, produces an html-response fragment of the post. +;; The fragment contains a link to show a detailed view of the post. +(define (render-post a-blog a-post make-url) + (define (view-post-handler request) + (render-post-detail-page a-blog a-post request)) + + `(div ((class "post")) + (a ((href ,(make-url view-post-handler))) + ,(post-title a-post)) + (p ,(post-body a-post)) + (div ,(number->string (length (post-comments a-post))) + " comment(s)"))) + +;; render-posts: blog (handler -> string) -> html-response +;; Consumes a make-url, produces an html-response fragment +;; of all its posts. +(define (render-posts a-blog make-url) + (define (render-post/make-url a-post) + (render-post a-blog a-post make-url)) + + `(div ((class "posts")) + ,@(map render-post/make-url (blog-posts a-blog)))) + +;; render-as-itemized-list: (listof html-response) -> html-response +;; Consumes a list of items, and produces a rendering as +;; an unorderered list. +(define (render-as-itemized-list fragments) + `(ul ,@(map render-as-item fragments))) + +;; render-as-item: html-response -> html-response +;; Consumes an html-response, and produces a rendering +;; as a list item. +(define (render-as-item a-fragment) + `(li ,a-fragment)) \ No newline at end of file