(module servlet-helpers mzscheme (require (lib "list.ss") (lib "etc.ss") (lib "xml.ss" "xml") (lib "base64.ss" "net") (lib "url.ss" "net") (lib "struct.ss")) (require "util.ss" "response.ss" "request-parsing.ss" "servlet-tables.ss") (provide get-host extract-binding/single extract-bindings exists-binding? extract-user-pass build-suspender make-html-response/incremental report-errors-to-browser redirect-to permanently temporarily see-other (all-from "request-parsing.ss") (rename get-parsed-bindings request-bindings) translate-escapes) ;; URL parsing (provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path)) servlet-url->url-string servlet-url->url-string/no-continuation servlet-url->servlet-url/no-extra-path request->servlet-url uri->servlet-url) (define-struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path)) (define (servlet-url->url-string/no-continuation su) (url->string (make-url (servlet-url-protocol su) #f #f ;(servlet-url-host su) #f ;(servlet-url-port su) #t (append (map (lambda (p/p) (if (and (not (empty? (path/param-param p/p))) ; XXX: not robust (match-url-params (first (path/param-param p/p)))) (make-path/param (path/param-path p/p) empty) p/p)) (servlet-url-servlets-root su)) (servlet-url-servlet-path su) (servlet-url-extra-path su)) empty #f))) (define (servlet-url->url-string su) (let ([the-url (make-url (servlet-url-protocol su) #f #f ;(servlet-url-host su) #f ;(servlet-url-port su) #t (append (reverse (rest (reverse (servlet-url-servlets-root su)))) (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su)))) empty)) (servlet-url-servlet-path su) (servlet-url-extra-path su)) empty #f)]) (if (and (servlet-url-instance-id su) (servlet-url-k-id su) (servlet-url-nonce su)) (embed-ids (servlet-url-instance-id su) (servlet-url-k-id su) (servlet-url-nonce su) the-url) (url->string the-url)))) (define (servlet-url->servlet-url/no-extra-path su) (copy-struct servlet-url su [servlet-url-extra-path empty])) (define (request->servlet-url req) (uri->servlet-url (request-uri req) (request-host-ip req) (request-host-port req))) (define uri->servlet-url (opt-lambda (uri [default-host #f] [default-port #f]) (let-values ([(k-instance k-id k-salt) (let ([k-parts (continuation-url? uri)]) (if k-parts (apply values k-parts) (values #f #f #f)))] [(servlet-path path) (let loop ([servlet-path empty] [path (rest (url-path uri))]) (if (empty? path) (values servlet-path path) (let ([cur (first path)]) (if (regexp-match "\\.ss$" (path/param-path cur)) (values (append servlet-path (list cur)) (rest path)) (loop (append servlet-path (list cur)) (rest path))))))]) (make-servlet-url (url-scheme uri) (or (url-host uri) default-host) (or (url-port uri) default-port) (list (first (url-path uri))) k-instance k-id k-salt servlet-path path)))) ;; get-host : Url (listof (cons Symbol String)) -> Symbol ;; host names are case insesitive---Internet RFC 1034 (define DEFAULT-HOST-NAME ') (define (get-host uri headers) (cond [(url-host uri) => string->symbol] [(assq 'host headers) => (lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))] [else DEFAULT-HOST-NAME])) ;; get-parsed-bindings : request -> (listof (cons sym str)) (define (get-parsed-bindings r) (let ([x (request-bindings/raw r)]) (if (list? x) x (parse-bindings x)))) ;; parse-bindings : (U #f String) -> (listof (cons Symbol String)) (define (parse-bindings raw) (if (string? raw) (let ([len (string-length raw)]) (let loop ([start 0]) (let find= ([key-end start]) (if (>= key-end len) null (if (eq? (string-ref raw key-end) #\=) (let find-amp ([amp-end (add1 key-end)]) (if (or (= amp-end len) (eq? (string-ref raw amp-end) #\&)) (cons (cons (string->symbol (substring raw start key-end)) (translate-escapes (substring raw (add1 key-end) amp-end))) (loop (add1 amp-end))) (find-amp (add1 amp-end)))) (find= (add1 key-end))))))) null)) ; extract-binding/single : sym (listof (cons str str)) -> str (define (extract-binding/single name bindings) (let ([lst (extract-bindings name bindings)]) (cond [(null? lst) (error 'extract-binding/single "~e not found in ~e" name bindings)] [(null? (cdr lst)) (car lst)] [else (error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)]))) ; extract-bindings : sym (listof (cons str str)) -> (listof str) (define (extract-bindings name bindings) (map cdr (filter (lambda (x) (equal? name (car x))) bindings))) ; exists-binding? : sym (listof (cons sym str)) -> bool ; for checkboxes (define (exists-binding? name bindings) (if (assq name bindings) #t #f)) ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response (define build-suspender (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null]) (lambda (k-url) `(html (head ,head-attributes (meta ([http-equiv "Pragma"] [content "no-cache"])) ; don't cache in netscape (meta ([http-equiv "expires"] [content "-1"])) ; don't cache in IE ; one site said to use -1, another said to use 0. (title . ,title)) (body ,body-attributes (form ([action ,k-url] [method "post"]) ,@content)))))) ; redirection-status = (make-redirection-status nat str) (define-struct redirection-status (code message)) (define permanently (make-redirection-status 301 "Moved Permanently")) (define temporarily (make-redirection-status 302 "Moved Temporarily")) (define see-other (make-redirection-status 303 "See Other")) ; : str [redirection-status] -> response (define redirect-to (opt-lambda (uri [perm/temp permanently]) (make-response/full (redirection-status-code perm/temp) (redirection-status-message perm/temp) (current-seconds) #"text/html" `((location . ,uri)) (list (redirect-page uri))))) ; : str -> str (define (redirect-page url) (xexpr->string `(html (head (meta ((http-equiv "refresh") (url ,url))) "Redirect to " ,url) (body (p "Redirecting to " (a ([href ,url]) ,url)))))) ; make-html-response/incremental : ((string -> void) -> void) -> response/incremental (define (make-html-response/incremental chunk-maker) (make-response/incremental 200 "Okay" (current-seconds) #"text/html" '() chunk-maker)) ; : (response -> doesn't) -> void ; to report exceptions that occur later to the browser ; this must be called at the begining of a servlet (define (report-errors-to-browser send/finish-or-back) (current-exception-handler (lambda (exn) (send/finish-or-back `(html (head (title "Servlet Error")) (body ([bgcolor "white"]) (p "The following error occured: " (pre ,(exn->string exn))))))))) ; Authentication (define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)")) (define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x)) ;:(define match-authentication (type: (str -> (or/c false (list str str str))))) ; extract-user-pass : (listof (cons sym bytes)) -> (or/c #f (cons str str)) ;; Notes (GregP) ;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1) ;; e.g. an authorization header will look like this: ;; Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ== ;; 2. Headers should be read as bytes and then translated to unicode as appropriate. ;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes (define (extract-user-pass headers) (let ([pass-pair (assq 'authorization headers)]) (and pass-pair (let ([basic-credentials (cdr pass-pair)]) (cond [(and (basic? basic-credentials) (match-authentication (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))) ) => (lambda (user-pass) (cons (cadr user-pass) (caddr user-pass)))] [else #f]))))) ;; basic?: bytes -> (or/c (listof bytes) #f) ;; does the second part of the authorization header start with #"Basic " (define basic? (let ([basic-regexp (byte-regexp #"^Basic .*")]) (lambda (some-bytes) (regexp-match basic-regexp some-bytes)))))