Teachpacks for How to Design Programs

# Scheme Web Servlets

### servlet.ss

The teachpack `servlet.ss` provides structures and functions for building Web servlets in Scheme. The data definitions represent HTTP requests and Web page responses using these two structures:

      (define-struct request (method uri headers bindings host-ip client-ip))

      (define-struct response/full (code message seconds mime extras body))

constrained as follows:

      Env      = (listof (cons Symbol String))
      Request  = (make-request (union 'get 'post) URL Env Env String String)
        ;; (search for "net" in Help Desk)
      Response =
       (union
         X-expression ;; represent XHTML (search for "XML" in help-desk)
         (cons String (listof String))
           ;; where the first string is the mime type from RFC 2822, often
           ;; "text/html", and the rest of the strings provide the document's
           ;; content.
         (make-response/full N String N String Env (listof String))
           ;; where the fields are interpreted as follows:
           ;;   code indicates the HTTP response code.
           ;;   message describes the code in human language.
           ;;   seconds indicates the origination time of the
           ;;   response. Use (current-seconds) for dynamically created responses.
           ;;   mime indicates the response type.
           ;;   extras is an environment with extra headers for redirects, authentication, or cookies.
           ;;   body is the message body.
      Suspender = String -> Response

The following functions empower servlets to interact with a Web browser:

- `build-suspender : (listof X-expr[HTML]) (listof X-expr[HTML]) [Env] [Env] -> Suspender`
  builds a suspender from lists of X-expressions for the head and the body of a Web page. The body is put into a form context. The function optionally consumes attributes for the `head` and `body` tags of the constructed page.
- `send/suspend : Suspender -> Request`
  sends the suspender's page to the browser and waits for the browser's request.
- `send/finish : Response -> Void`
  sends the response to the browser and terminates the servlet (and the REPL, when used inside of DrScheme).
- `initial-request : Request`
  a fictitious request that looks like a browser initially requested the servlet's URL.
- `extract-binding/single : Symbol Env -> string`
  consumes the symbol of an HTML form field and a bindings environment. It returns the only value associated with the given symbol. It raises an exception when zero or more than one input is provided for a single symbol.
- `extract-bindings : Symbol Env -> (listof String)`
  consumes a symbol and a bindings environment. It produces all the values associated with that symbol.
- `extract-string : String Env -> (listof String)`
  consumes a string and a bindings environment. It produces all the values associated with that string.
- `exists-binding? : Symbol Env -> Boolean`
  consumes a symbol and a bindings environment. It produces true when the symbol is bound. This is useful for checkboxes.
- `extract-user-pass : Env -> (union false (cons string string))`
  extracts the username and the password from the HTTP headers environment, if provided. Servlets may use this function to implement password based authentication.

Here is a sample script that permits consumers to login to a site:

    ; Request -> Request
    (define (get-login-information request0)
      (let* ([bindings (request-bindings request0)]
             [name (extract-bindings 'Name bindings)]
             [form '((input ([type "text"][name "Name"][value "<Last Name>"]))
                     (br)
                     (input ([type "password"][name "Passwd"]))
                     (br)
                     (input ([type "submit"][value "Login"])))])
        (if (null? name)
            (send/suspend
             (build-suspender
              '("Login")
              form))
            (send/suspend
             (build-suspender
              '("Repeat Login")
              `(("Dear "
                 ,(car name)
                 " your username didn't match your password. Please try again."
                 (br))
                ,@form))))))

    ; Request -> Void
    (define (check-login-information request)
      (let* ([bindings (request-bindings request)]
             [name     (extract-binding/single 'Name bindings)]
             [passwd   (extract-binding/single 'Passwd bindings)])
        (if (and (string=? "Paul" name) (string=? "Portland" passwd))
            request
            (check-login-information (get-login-information request)))))

    ; Request -> Void
    (define (welcome request)
      (let ([bindings (request-bindings request)])
        (send/finish
         `(html
           ,(extract-binding/single 'Name bindings)
           " Thanks for using our service."
           " We're glad you recalled that your password is "
           ,(extract-binding/single 'Passwd bindings)))))

    ; RUN:
    (welcome
     (check-login-information
      (get-login-information initial-request)))