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))
 

  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 ""]))
                 (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)))