Test page

;; @module Response ;; @author Jeff Ober , Kanen Flowers ;; @version 1.2.1 ;; @location http://static.artfulcode.net/newlisp/response.lsp ;; @package http://static.artfulcode.net/newlisp/response.qwerty ;; @description Response module to replace output functions in the standard CGI module (updated for newlisp 10) ;; This module is independent of the Http module, and duplicates some of the effort there ;; by providing the ability to write headers to the HTTP output (such as the content-type and ;; the ability to redirect). It is meant to be used with an existing CGI serving application, ;; such as Apache. ;; ;; Output is controlled using 'Response:write' or default functor (`Response:Response`), ;; which formats the output as a CGI response. The result of 'Response:Response' is a ;; formatted string. It is the application's responsibility to print this string or pass ;; it to the appropriate middle-man. ;; ;;

Version history

;; 1.2.1 ;; • replaced deprecated set-assoc with setf in Response:header ;; ;; 1.2 ;; • fixed incompatibilities with newlisp 10 ;; ;; 1.1 ;; • fixed bug in 'headers' ;; • fixed bug forcing text/html on all responses ;; ;; 1.0 ;; • initial release (context 'Response) (set '_response-codes '((200 "OK") (302 "Found") (404 "Not Found") (500 "Internal Error"))) (set '_response-code 200) (set '_content-type "text/html; charset=utf-8") (set '_headers '(("Content-type" "text/html; charset=utf-8"))) (set '_cookies '()) (set '_content "") ;;; functions for setting headers, adding content, and predicates. ;; @syntax (Response:write ...) ;; @param text to write to the output buffer ;;

'Response:write' allows programmatic output of CGI content.

;; @example ;; (Response:write "\n") ;; (Response:write "Test page\n") ;; (Response:write "

Hello world

\n") ;; (Response:write "") (define (Response:write) (doargs (a) (write-buffer _content (string a)))) ;; @syntax (Response:header

) ;; @param header name ;; @param header content ;;

Adds a new header to the output.

(define (header key val) (set 'key (title-case key)) (if (assoc key _headers) (setf (assoc key _headers) (list key val)) (push (list key val) _headers))) ;; @syntax (Response:header? ) ;; @param header name ;;

Predicates that a header has already been added for output.

(define (header? key) (lookup key _headers)) ;; @syntax (Response:headers) ;;

Returns an association list of headers that have been set.

(define (headers) _headers) (define (format-cookie key value domain path expires) ;; expires must be timestamp (set 'value (if value (string value) "")) (let ((cookie "")) (write-buffer cookie (format "%s=%s;" key value)) (if domain (write-buffer cookie (format "; domain=.%s" domain))) (if path (write-buffer cookie (format "; path=%s" path))) (if expires (write-buffer cookie (format "; expires=%s" (date (int expires) 0 "%a, %d %b %Y %H:%M:%S %Z")))) cookie)) ;; @syntax (Response:set-cookie

[ [ []]]) ;; @param the cookie's name ;; @param the cookie's value ;; @param optional; the cookie's domain ;; @param optional; the cookie's path ;; @param optional; integer timestamp suitable as an input to 'date' ;;

Adds a cookie to the output buffer.

;; @example ;; (let ((sid (new-session-id))) ;; (Response:set-cookie "session-id" sid nil nil (+ (date-value) (* 60 60)))) ;; ;; => sets cookie "session-id" to the result of the function 'new-session-id' and ;; an expiration date one hour in the future. (define (set-cookie key value domain path expires) (if (cookie-set? key '? domain path) (delete-cookie key domain path)) (push (list key value domain path expires) _cookies -1)) ;; @syntax (Response:delete-cookie [ []]) ;; @param the cookie's name ;; @param optional; the cookie's domain ;; @param optional; the cookie's path ;;

Deletes a cookie with matching key/domain/path that has been previously set.

;;; TODO: needs to check for set cookies in _cookies and remove (define (delete-cookie key domain path) (if (cookie-set? key '? domain path) (pop _cookies (find (list key '? domain path '?) _cookies match)) (set-cookie key nil domain path (date-value)))) ;; @syntax (Response:cookie-set? [ []]) ;; @param the cookie's name ;; @param optional; the cookie's domain ;; @param optional; the cookie's path ;;

Predicates whether a cookie with a matching pattern has been previously set.

(define (cookie-set? key domain path) (true? (find (list key '? domain path '?) _cookies match))) ;;; utility functions for rendering of headers (define (_write-cookies) (if-not (null? _cookies) (let ((buffer "")) (dolist (cookie _cookies) (set 'cookie (apply format-cookie cookie)) (write-buffer buffer (string "Set-Cookie: " cookie "\n"))) buffer) "")) (define (_write-content str) (if str (set '_content str)) (if _content (let ((buffer "")) (write-buffer buffer (string "Content-Length: " (length _content) "\n\n")) (write-buffer buffer (string _content)) buffer) "")) (set '_response (lambda (str) (let ((buffer "")) (let ((response-text (lookup _response-code _response-codes))) (write-buffer buffer (string "Status: " _response-code " " (lookup _response-code _response-codes) "\n")) (dolist (hdrs _headers) (write-buffer buffer (string (join hdrs ": ") "\n"))) (write-buffer buffer (_write-cookies)) (write-buffer buffer (_write-content str)) buffer)))) ;;; functions that render complete headers. functions that need to override the ;;; default rendering of complete headers simply need to replace the lambda ;;; _response which returns a string containing the complete header. ;; @syntax (Response:Response []) ;; @param optional; string text to output ;;

The default functor will return a formatted response, suitable for CGI output. ;; If is provided, this will be the output. Otherwise, any content added ;; with 'Response:write' will be used.

;;

Output will include any necessary headers, including cookies, that were set ;; for this session.

;;

This module is not re-entrant, so in a stateful environment, it should be ;; prototyped using 'new' for each new response.

;;

The manner in which the response is rendered may be hacked by setting the ;; variable 'Response:_response' to a suitable lambda expression. See the code for ;; more implementation details.

;; @example ;; (Response "Hello world") ;; => "Status: 200 OK\nContent-type: text/html; charset=utf-8\nContent-Length: 11\n\nHello world" ;; ;; (Response:write "Hello world") ;; (Response) ;; => "Status: 200 OK\nContent-type: text/html; charset=utf-8\nContent-Length: 11\n\nHello world" (define (Response:Response str) (_response str)) ;; @syntax (Response:redirect ) ;; @param the url or path to redirect to ;;

Redirects the client to .

;; @example ;; (Response:redirect "/some/other/path") ;; => "Status: 302 Found\nLocation: /some/other/path\n\n" (define (redirect path) (set '_response-code 302) (header "Location" path) (set '_response (expand '(lambda () (string "Status: 302 Found\n" (_write-cookies) "Location: " path "\n\n")) 'path)) (_response)) ;;; 404 and 500 errors accept a string to output as the 404 page or 500 page. ;;; These are useful as primitives for more sophisticated error-catching ;;; routines that output formatted error and not-found pages. ;; @syntax (Response:not-found ) ;; @param 404 NOT FOUND error message to display ;;

Outputs a 404 NOT FOUND error message.

;; @example ;; (Response:not-found "

These are not the droids you are looking for.

") ;; => "Status: 404 Not Found\nContent-type: text/html; charset=utf-8\nContent-Length: 52\n\n

These are not the droids you are looking for.

" (define (not-found str) (set '_response-code 404) (set '_content str) (_response)) ;; @syntax (Response:error ) ;; @param 500 ERROR message to display ;;

Outputs a 500 ERROR message.

;; @example ;; (Response:error "

An error occurred while processing this request.

") ;; => "Status: 500 Internal Error\nContent-type: text/html; charset=utf-8\nContent-Length: 55\n\n

An error occurred while processing this request.

" (define (error str) (set '_response-code 500) (set '_content str) (_response)) (context MAIN)