WebGate: Check-in [bc50958c55]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview

Comment:	More consistent signature for make-redirect-response
Downloads:	Tarball \| ZIP archive \| SQL archive
Timelines:	family \| ancestors \| descendants \| both \| trunk
Files:	files \| file ages \| folders
SHA1:	bc50958c55b1b13a1872fa4f0af533413196368f
User & Date:	murphy 2013-05-31 12:37:39

Context

2013-05-31
23:14		Clean up tcp listener in webgate-main using dynamic wind check-in: 22158254d8 user: murphy tags: trunk
12:37		More consistent signature for make-redirect-response check-in: bc50958c55 user: murphy tags: trunk
12:24		make-redirect-response utility procedure check-in: e1670c701e user: murphy tags: trunk

Changes

Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to example.scm.

;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(eval-when (eval load)
  (require-library webgate))

;; Use -extend at-expr during compilation!
(eval-when (eval)
  (import (only webgate-utils use-at-read-table))
  (use-at-read-table #:list-arguments? #t))

(import
 webgate (only webgate-utils uri-encode))

(define common-head
  '@head{
     @meta[(charset "utf-8")]
     @meta[(name "viewport") (content "width=device-width, initial-scale=1.0")]
     @title{WebGate}
     @meta[(name "description") (content "CHICKEN WebGate example")]
................................................................................

(define common-foot
  '@{
    @script[(src "/js/jquery.min.js")]
    @script[(src "/js/bootstrap.min.js")]
   })

(define-resource (root parameters)



  (make-html-response
   200
   `@html{
      @,common-head
      @body{
        @div[(class "navbar navbar-inverse navbar-fixed-top")]{
          @div[(class "navbar-inner")]{
................................................................................
					   `(span
					     (span
					      ((class "label notice"))
					      "Image Content:")
					     " "
					     (img
					      ((src ,(string-append
						      "data:" type ","
						      (uri-encode
						       (message-body msg))))))))
					  (else
					   `(span
					     (span
					      ((class "label notice"))
					      "Omitted Content:")
					     " "

;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.


(require-library webgate)

;; Use -extend at-expr during compilation!
(eval-when (eval)
  (import (only webgate-utils use-at-read-table))
  (use-at-read-table #:list-arguments? #t))

(import
 webgate (only webgate-utils base64-encode))

(define common-head
  '@head{
     @meta[(charset "utf-8")]
     @meta[(name "viewport") (content "width=device-width, initial-scale=1.0")]
     @title{WebGate}
     @meta[(name "description") (content "CHICKEN WebGate example")]
................................................................................

(define common-foot
  '@{
    @script[(src "/js/jquery.min.js")]
    @script[(src "/js/bootstrap.min.js")]
   })

(define-resource (root* parameters)
  (make-redirect-response 301 (resource-uri root)))

(define-resource (root "root" parameters)
  (make-html-response
   200
   `@html{
      @,common-head
      @body{
        @div[(class "navbar navbar-inverse navbar-fixed-top")]{
          @div[(class "navbar-inner")]{
................................................................................
					   `(span
					     (span
					      ((class "label notice"))
					      "Image Content:")
					     " "
					     (img
					      ((src ,(string-append
						      "data:" type ";base64,"
						      (base64-encode
						       (message-body msg))))))))
					  (else
					   `(span
					     (span
					      ((class "label notice"))
					      "Omitted Content:")
					     " "

Changes to webgate-core.scm.

	(title ,status-line))
       (body
	(h1 ,status-line)
	(p ,message))))
   #:status-message status-message
   #:headers headers))

(define (make-redirect-response target #!optional permanent?)


  (make-error-response
   (if permanent? 301 307) `(a ((href ,target)) ,target)
   #:headers `(("Location" . ,target))))





(define (write-response rsp #!optional (port (current-output-port)))
  (fprintf
   port "Status: ~a ~a\r\n"
   (response-status rsp) (response-status-message rsp))
  (write-message rsp port))








|
>
>
|
|
|
>
>
>
>

	(title ,status-line))
       (body
	(h1 ,status-line)
	(p ,message))))
   #:status-message status-message
   #:headers headers))

(define make-redirect-response
  (case-lambda
   ((status target)
    (make-error-response
     status `(a ((href ,target)) ,target)
     #:headers `(("Location" . ,target))))
   ((target)
    (make-error-response
     302 `(a ((href ,target)) ,target)
     #:headers `(("Location" . ,target))))))

(define (write-response rsp #!optional (port (current-output-port)))
  (fprintf
   port "Status: ~a ~a\r\n"
   (response-status rsp) (response-status-message rsp))
  (write-message rsp port))