From a1cf68700e196afb712612c758d0621088558303 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Aug 2005 16:03:24 +0000 Subject: [PATCH] Adding back servlet teachpacks svn: r648 --- collects/htdp/servlet.ss | 45 ++++ collects/htdp/servlet2.ss | 424 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 469 insertions(+) create mode 100644 collects/htdp/servlet.ss create mode 100644 collects/htdp/servlet2.ss diff --git a/collects/htdp/servlet.ss b/collects/htdp/servlet.ss new file mode 100644 index 0000000000..a34dba9db4 --- /dev/null +++ b/collects/htdp/servlet.ss @@ -0,0 +1,45 @@ +; Author: Paul Graunke +#cs(module servlet mzscheme + (require (lib "servlet-env.ss" "web-server") + (lib "error.ss" "htdp") + (lib "xml.ss" "xml") + (lib "list.ss") + (lib "prim.ss" "lang") + (lib "unitsig.ss")) + (provide (all-from-except (lib "servlet-env.ss" "web-server") build-suspender) + (rename wrapped-build-suspender build-suspender)) + + (define wrapped-build-suspender + (case-lambda + [(title content) + (check-suspender2 title content) + (build-suspender title content)] + [(title content body-attributes) + (check-suspender3 title content body-attributes) + (build-suspender title content body-attributes)] + [(title content body-attributes head-attributes) + (check-suspender4 title content body-attributes head-attributes) + (build-suspender title content body-attributes head-attributes)])) + + ; : tst tst -> void + (define (check-suspender2 title content) + (check-arg 'build-suspender (listof? xexpr? title) "(listof xexpr[HTML])" "1st" title) + (check-arg 'build-suspender (listof? xexpr? content) "(listof xexpr[HTML])" "2nd" content)) + + ; : tst tst tst -> void + (define (check-suspender3 title content body-attributes) + (check-suspender2 title content) + (check-arg 'build-suspender (listof? attribute-pair? body-attributes) + "(listof (cons sym str))" "3rd" body-attributes)) + + ; : tst tst tst tst -> void + (define (check-suspender4 title content body-attributes head-attributes) + (check-suspender3 title content body-attributes) + (check-arg 'build-suspender (listof? attribute-pair? head-attributes) + "(listof (cons sym str))" "4th" head-attributes)) + + ; : tst -> bool + (define (attribute-pair? b) + (and (pair? b) + (symbol? (car b)) + (string? (cdr b))))) diff --git a/collects/htdp/servlet2.ss b/collects/htdp/servlet2.ss new file mode 100644 index 0000000000..1b74f19bb7 --- /dev/null +++ b/collects/htdp/servlet2.ss @@ -0,0 +1,424 @@ +(module servlet2 mzscheme + #| TODO ----------------------------------------------------------------------- + buttons: multiple points of returns: continuation functions + |# + (require (lib "servlet-env.ss" "web-server") + (lib "error.ss" "htdp") + (lib "list.ss") + (lib "etc.ss")) + (provide (all-from (lib "servlet-env.ss" "web-server")) + + single-query ; FormElement -> Answer + + queries ; (listof FormElement) -> (listof Answer) + echo-answers ; (listof Answers) -> true + + form-query ; Form -> Response + echo-response ; Response -> true + extract/single ; Symbol Response -> Answer + extract ; Symbol Response -> (listof Answer) + + inform ; String String *-> true + inform/html ; (listof Xexpr) -> true + final-page ; String String *-> true + + ; Structures -------------------------------------------------------------- + make-password + (rename make-numeric make-number) + make-yes-no + (rename make-check make-boolean) + make-radio + ; make-button + + form? + form-element? + + #| Data Definitions -------------------------------------------------------- + + FormElement = (union String + (make-password String) + (make-number String) + (make-boolean String) + (make-yes-no String String String) + (make-radio String (cons String (listof String))) + (make-button String)) + + FormItem = (list Symbol FormElement) + Form = (cons FormItem (listof FormItem)) + + Answer = (union String Number Boolean) + Response = (listof (list Symbol Answer)) + |# + ) + + ; ;; + ;;;;; ; ;;; ;;;;; ; + ; ; ; ; ; ; ;; ; + ; ; ;;;; ;;;;; ;;;; ; ; ; ; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; + ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;; ; ;;;; ;;; ; ;;;; ; ; ; ; ; ; ; ; ;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;; ; ; ; ; ; + ;;;;; ;;; ; ;;; ;;; ; ;;; ; ;;;; ;;;; ;;; ; ;;;;; ;;; ; ;;; + + + #| Documentation ------------------------------------------------------------ + (define-checked (name pred_1? ... pred_n?)) + re-defines the constructor make-name so that it makes sure that its + n arguments satisfy pred_1? ... pred_n? + + Note: + to maintain the invariant, also modify the mutators to check their arguments + |# + (define-syntax (define-checked stx) + (syntax-case stx () + [(_ (name pred? ...)) + (let ([make-variable + ; String SyntaxObject -> SyntaxObject + (lambda (x y) + (datum->syntax-object + stx + (string->symbol + (format "~a-~a" x (syntax-object->datum y)))))]) + (with-syntax ([make-name (make-variable "make" (syntax name))] + [(x ...) (generate-temporaries (syntax (pred? ...)))]) + (syntax + (set! make-name + (let ([make-name make-name]) + (lambda (x ...) + (check-arg 'make-name (pred? x) pred? "an" x) + ... + (make-name x ...)))))))])) + ; _ -> true + (define (true? x) #t) + + ;; Structure Definitions ---------------------------------------------------- + (define-struct fe (question)) + + (define-struct (password fe)()) + (define-struct (numeric fe) ()) + (define-struct (check fe) ()) + (define-struct (yes-no fe) (positive negative)) + (define-struct (radio fe) (labels)) + + (define-checked (password string?)) + (define-checked (numeric string?)) + (define-checked (check string?)) + (define (list-of-strings? l) + (and (list? l) (andmap string? l))) + (define-checked (radio string? list-of-strings?)) + (define-checked (yes-no string? true? true?)) + + ; todo + (define-struct (button fe) ()) + + + ; _ -> (union true String) + (define (form? x) + (cond + [(not (list? x)) (format "list expected, given ~e" x)] + [(find-non list? x) + => + (lambda (non-list) + (format "list of lists expected, give list with ~e" non-list))] + [(find-non + (lambda (x) + (and (list? x) + (= (length x) 2) + (symbol? (car x)) + (form-element? (cadr x)))) + x) + => + (lambda (non-tagged-fe) + (format "list of (list Symbol FormElement) expected, given ~s" non-tagged-fe))] + [else true])) + + ; _ -> Boolean + (define (form-element? x) + (cond + [(string? x) #t] + [(fe? x) (and + (string? (fe-question x)) + (cond + [(radio? x) (and (non-empty-list? (radio-labels x)) + (andmap string? (radio-labels x)))] + [(yes-no? x) (and (string? (yes-no-positive x)) + (string? (yes-no-negative x)))] + [else #t]))] + [else #f])) + + ; _ -> Boolean + (define (non-empty-list? x) + (and (cons? x) (list? x))) + + ; + ;; ;; + ;; ;; + ;; ;; ;;;; ;;; ; ;;; ;;; + ; ; ; ; ; ;; ; ; ; + ; ; ; ;;;; ; ; ; ;;; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; + ;;; ;;; ;;; ; ;;;;; ;;; ;; ;;; + + + ; posing questions ---------------------------------------------------------- + + ; FormElement -> Answer + ; to pose one question, receive one answer + (define (single-query fe) + (check-arg 'single-query (form-element? fe) "form element" "first" fe) + (car (queries (list fe)))) + + ; (listof FormElement) -> (listof Answer) + ; to ask N questions and to get N answers + ; assert: (lambda (result) (= (length fes) (length result))) + (define (queries fes) + (check-arg 'queries (and (list? fes) (andmap form-element? fes)) + "list of form elements" "first" fes) + (conduct-query "Web Query" (map list (make-keys fes) fes))) + + ; Form -> Bindings + ; to ask N questions with tags, receive N answers + ; assert: (lambda (result) (set-equal? (map car aloss) (map car result))) + (define (form-query f) + (check-list-list 'form-query (form? f) "form" f) + (map list (map first f) + (conduct-query "Web Query" (map list (make-keys f) (map second f))))) + + + ; extracting values from forms ---------------------------------------------- + + ; extract : Symbol Response -> (listof Answer) + ; extract all answers associated with a tag + (define (extract tag r) + (map second (filter (lambda (a) (eq? (first a) tag)) r))) + + ; extract/single : Symbol Response -> Answer + (define (extract/single tag r) + (let ([all (extract tag r)]) + (if (and (pair? all) (null? (rest all))) ; (= (length all) 1) + (first all) + (cond + [(null? all) + (error 'extract/single "~e contains no tag ~e" r tag)] + [else + (error 'extract/single "~e contains more than one tag ~e" r tag)])))) + + ; echoing responses --------------------------------------------------------- + + ; Response -> true + ; to display a response on a web page + (define (echo-response form) + (make-echo-page + (map (lambda (tag answer) + `(tr (td ,(symbol->string tag)) + (td ,(answer->string answer)))) + (map first form) + (map second form)))) + + ; (listof Answer) -> true + ; to display a list of answers on a web page + (define (echo-answers form) + (make-echo-page + (map (lambda (answer) `(tr (td ,(answer->string answer)))) form))) + + ; displaying information ---------------------------------------------------- + + ; String String *-> true + ; to deliver an intermediate message and a link to continue + (define (inform title . paragraph) + (check-arg 'inform (string? title) "string" "first" title) + (check-arg 'inform (andmap string? paragraph) + "list of strings" "second, third, ..." paragraph) + (send/suspend + (lambda (url) + `(html + (title ,title) + (body ([bgcolor "white"]) + (h3 ,title) + (br) + (p ,@paragraph) + (br) + (a ([href ,url]) "Continue"))))) + #t) + + ; (listof Xexpr) -> true + (define (inform/html stuff) + (send/suspend + (lambda (url) + `(html + (title "Information") + (body ([bgcolor "white"]) + (hr) + (div ,@stuff) + (hr) + (a ([href ,url]) "Continue"))))) + #t) + + ; String String *-> true + ; to deliver a final web page and terminate the web dialog + (define (final-page title . paragraph) + (check-arg 'final-page (string? title) "string" "first" title) + (check-arg 'final-page (andmap string? paragraph) + "list of strings" "second, third, ..." paragraph) + (send/finish + `(html + (title ,title) + (body ([bgcolor "white"]) + (h3 ,title) + (br) + (p ,@paragraph)))) + #t) + + + ; ;;; ; ; + ;;; ; + ; ; + ; ; ;; ;; ;;; ;;; ;;; ; ;;; ;;;; ; ;;; ;;; ;;; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ;;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ;;; ;;; ;;; ;;; ;; ;;;;; ;;;;;; ;;;;; ;;; ; ;;;; ;;;;; ;;; ;;; + + ; String Form -> FormResults + (define (conduct-query text aloss) + (let ([keys (map car aloss)]) + (let cq ([text text]) + (let ([res (build-form text aloss)]) + (let/ec restart + (map (lambda (k fe) + (get-binding restart (string->symbol k) res (cadr fe) cq)) + keys aloss)))))) + + ; String (String -> (listof Answer)) -> (listof Answer) + (define (handle message cq n) + (cq `(font ([color "red"]) ,(string-append message " " (fe-question n))))) + + ; Continuation Symbol Bindings FormElement -> Answer + ; effect: raise 'yes-no if a yes-no button goes unchecked + (define (get-binding restart tag bindings fe cq) + (let ([cq (compose restart cq)] + [result (extract-bindings tag bindings)] + [question "Please respond to the question:"]) + (cond + [(check? fe) (if (null? result) #f #t)] + [(numeric? fe) + (if (null? result) + (handle question cq fe) + (let ([r (string->number (car result))] + [question "Please respond with a number to the question:"]) + (if r r (handle question cq fe))))] + [(yes-no? fe) + (if (null? result) (handle question cq fe) (car result))] + [(radio? fe) + (if (null? result) (handle question cq fe) (car result))] + [(button? fe) ; at most one button should be clicked + (if (null? result) #f (car result))] + [(null? result) (format "error ~e -> ~e :: ~e" tag fe bindings)] + [else (car result)]))) + + ; String Form -> FormResults + ; assert: (lambda (result) (set-equal? (domain aloss) (domain result))) + (define (build-form title f) + (request-bindings + (send/suspend + (lambda (url) + `(html + (title ,title) + (body ([bgcolor "white"]) + (h3 ,title) + (br) + (form ([action ,url][method "post"]) + (table ,@(map build-row f)) + ,@(add-submit-button (map second f))))))))) + + ; build-row : (list Symbol FormElement) -> Xexpr[tr] + (define (build-row x) + (let* ([tag (first x)] + [fe (second x)] + [rad (lambda (x) + `(td (input ([type "radio"][name ,tag][value ,x])) " " ,x))] + [make-radio + (lambda (loq) `(td (table (tr ,@(map rad loq)))))]) + (cond + [(string? fe) + `(tr (td ,fe) (td (input ([type "text"][name ,tag][value ""]))))] + [(password? fe) + `(tr (td ,(fe-question fe)) + (td (input ([type "password"][name ,tag]))))] + [(numeric? fe) + `(tr (td ,(fe-question fe)) + (td (input ([type "text"][name ,tag]))))] + [(check? fe) + `(tr (td ,(fe-question fe)) + (td (input ([type "checkbox"][name ,tag][value ,(fe-question fe)]))))] + [(yes-no? fe) + `(tr (td ,(fe-question fe)) + ,(make-radio (list (yes-no-positive fe) (yes-no-negative fe))))] + [(radio? fe) + `(tr (td ,(fe-question fe)) ,(make-radio (radio-labels fe)))] + [(button? fe) + `(tr (td) + (td (input ([type "submit"][name ,tag][value ,(fe-question fe)]))))] + [else (error 'build-row "can't happen: ~e" fe)]))) + + ; (listof Forms) -> (union Empty (list SUBMIT-BUTTON)) + (define (add-submit-button fes) + (if (pair? (cdr fes)) + (if (ormap button? fes) '() (list SUBMIT-BUTTON)) + (let ([fe (car fes)]) + (if (or (string? fe) (password? fe) (numeric? fe)) + '() + (list SUBMIT-BUTTON))))) + + ;; ;; + ;;; ; ; + ; ; ; ; + ; ; ; ;; ;;; ;;; ; ;; ;;; + ; ;; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ;; ;;; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ;;; ;;; ;;; ;;; ;;; ;; ;; ;;; + + + ; Answer -> String + (define (answer->string a) + (cond + [(string? a) (format "~s" a)] + [(number? a) (number->string a)] + [(boolean? a) (if a "true" "false")] + [else (format "~a" a)])) + + ; --------------------------------------------------------------------------- + ; (listof X) -> (listof String) + ; make unique, readable string/tags for a list of queries + (define make-keys + (let ([counter 0]) + (lambda (fes) + (map (lambda (x) + (set! counter (+ counter 1)) + (format "tag~a" counter)) + fes)))) + + ; --------------------------------------------------------------------------- + ; (listof Xexpr[tr]) -> true + ; echo stuff, wait for click on continue link + (define (make-echo-page stuff) + (send/suspend + (lambda (url) + `(html + (title "Echoed Answers") + (body ([bgcolor "white"]) + (br) + (table + ,@stuff) + (br) + (a ([href ,url]) "Continue"))))) + #t) + + ; constants ----------------------------------------------------------------- + (define SUBMIT-BUTTON '(input ([type "submit"][value "Submit"]))) + ) \ No newline at end of file