WebGate

Artifact Content
Login

Artifact 250d80081b12a6673e8e3afaf3ae16bd560440c9:


;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate for CHICKEN.
;; Copyright (c) 2011-2013 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; 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")]
     @meta[(name "author") (content "Thomas Chust")]
     @link[(rel "stylesheet") (href "/css/bootstrap.min.css")]
     @link[(rel "stylesheet") (href "/css/bootstrap-responsive.min.css")]
     @style[(type "text/css")]{body{padding-top:60px; padding-bottom:40px}}
   })

(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")]{
	    @div[(class "container")]{
	      @a[(class "brand") (href "#")]{WebGate}
	      @div[(class "nav-collapse collapse")]{
	        @ul[(class "nav")]{
	          @li[(class "active")]{@a[(href "#")]{Miscellaneous}}
	          @li{@a[(href ,(resource-uri calc "add"))]{Suspensions}}
	        }
	      }
	    }
	  }
        }
        @div[(class "container")]{
          @div[(class "hero-unit")]{
	    @h1{Application Example}
	    @p{
	      This sample program just shows some information
              extracted from the incoming request.
	    }
	  }
	  @div[(class "row")]{
	    @div[(class "span8")]{
	      @h2{Present Context}
	      @table[(class "zebra-striped")]{
	        @thead{
		  @tr{@th{Key} @th{Value}}
		}
		@tbody{
		  @,@(let ((getenv (resource-context-getenv
				    (current-resource-context))))
		       `((tr (td "SCRIPT_NAME")
			     (td (code ,(or (getenv "SCRIPT_NAME") "<unknown>"))))
			 (tr (td "PATH_INFO")
			     (td (code ,(or (getenv "PATH_INFO") "<unknown>"))))
			 (tr (td "REQUEST_METHOD")
			     (td (code ,(or (getenv "REQUEST_METHOD") "<unknown>"))))))
		}
	      }
	    }
	    @div[(class "span8")]{
	      @h2{Present Parameters}
	      @table[(class "zebra-striped")]{
	        @thead{
		  @tr{@th{Key} @th{Messages}}
		}
		@tbody{
		  @,@(map
		      (lambda (key+msgs)
			(let-values (((key msgs) (car+cdr key+msgs)))
			  `(tr
			    (td ,key)
			    (td
			     (ol
			      ,@(map
				 (lambda (msg)
				   `(li
				     (p
				      ,(let ((type (message-type msg)))
					 (cond
					  ((message-text msg)
					   => (lambda (txt)
						`(span
						  (span
						   ((class "label notice"))
						   "Text Content:")
						  " " ,txt)))
					  ((string-prefix? "image/" type)
					   `(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:")
					     " "
					     (code ,type)))))
				      ,@(map
					 (lambda (header)
					   (let-values (((key value) (car+cdr header)))
					     `(span
					       ", "
					       (span ((class "label")) ,key ":")
					       " "
					       (code ,value))))
					 (message-headers msg)))))
				 msgs))))))
		      (hash-table->alist parameters))
		}
	      }
	    }
	  }
	  @div[(class "row")]{
	    @div[(class "span8")]{
	      @h2{GET with Parameters}
	      @form[(method "GET") (action ,(resource-uri root))]{
	        @fieldset{
		  @legend{Stuff}
		  @div[(class "clearfix")]{
		    @label[(for "some-thing0")]{Some value}
		    @div[(class "input")]{
		      @input[(type "text") (id "some-thing0") (class "medium")
			     (name "some-thing") (size "30")]
		    }
		  }
		  @div[(class "clearfix")]{
		    @label[(for "other-things0")]{Other values}
		    @div[(class "input")]{
		      @select[(id "other-things0") (class "medium")
			      (name "other-things") (multiple "multiple")]{
		        @option{foobaz}
			@option{dosh}
			@option{gostak}
		      }
		    }
		  }
		  @div[(class "actions")]{
		    @input[(type "submit") (class "btn primary")
			   (value "Submit")]
		    @nbsp
		    @input[(type "reset") (class "btn")
			   (value "Reset")]
		  }
		}
	      }
	    }
	    @div[(class "span8")]{
	      @h2{POST with Parameters}
	      @form[(method "POST") (enctype "multipart/form-data")
		    (action ,(resource-uri root))]{
	        @fieldset{
		  @legend{Upload}
		  @div[(class "clearfix")]{
		    @label[(for "some-thing1")]{Some value}
		    @div[(class "input")]{
		      @input[(type "text") (id "some-thing1") (class "medium")
			     (name "some-thing") (size "30")]
		    }
		  }
		  @div[(class "clearfix")]{
		    @label[(for "file-thing1")]{Some file}
		    @div[(class "input")]{
		      @input[(type "file") (id "file-thing1") (class "medium")
			     (name "file-thing")]
		    }
		  }
		  @div[(class "actions")]{
		    @input[(type "submit") (class "btn primary")
			   (value "Submit")]
		    @nbsp
		    @input[(type "reset") (class "btn")
			   (value "Reset")]
		  }
		}
	      }
	    }
	  }
	  @footer{@copy 2011-2013 by Thomas Chust}
	}
	@,@common-foot
      }
    }))

(define numeric-parameter
  (cute
   parameter-ref <> <>
   (lambda (v)
     (cond
      ((message-text v) => string->number)
      (else #f)))))

(define-resource (calc "calc" op parameters)
  (if (string=? op "add")
      (let* ((common-topbar
	      `@div[(class "navbar navbar-inverse navbar-fixed-top")]{
		 @div[(class "navbar-inner")]{
		   @div[(class "container")]{
		     @a[(class "brand") (href "#")]{WebGate}
		     @div[(class "nav-collapse collapse")]{
		       @ul[(class "nav")]{
		         @li{@a[(href ,(resource-uri root))]{Miscellaneous}}
		         @li[(class "active")]{@a[(href "#")]{Suspensions}}
		       }
		     }
		   }
		 }
	       })
	     (parameters
	      (send/suspend
	       (lambda (resume-uri)
		 (make-html-response
		  200
		  `@html{
		     @,common-head
		     @body{
		       @,common-topbar
		       @div[(class "container")]{
		         @form[(method "GET") (action ,resume-uri)]{
			   @fieldset{
			     @legend{Add Numbers}
			     @div[(class "clearfix")]{
			       @label[(for "a")]{First Summand}
			       @div[(class "input")]{
			         @input[(type "text") (id "a") (class "medium")
					(name "a") (size "30")]
			       }
			     }
			     @div[(class "clearfix")]{
			       @label[(for "a")]{Second Summand}
			       @div[(class "input")]{
			         @input[(type "text") (id "b") (class "medium")
					(name "b") (size "30")]
			       }
			     }
			     @div[(class "actions")]{
			       @input[(type "submit") (class "btn primary")
				      (value "Submit")]
			       @nbsp
			       @input[(type "reset") (class "btn")
				      (value "Reset")]
			     }
			   }
			 }
		       }
		     }
		   }))))
	     (a
	      (or (numeric-parameter parameters "a") 0))
	     (b
	      (or (numeric-parameter parameters "b") 0)))
	(make-html-response
	 200
	 `@html{
	    @,common-head
	    @body{
	      @,common-topbar
	      @div[(class "container")]{
	        @div[(class "hero-unit")]{
		  @h1{@,(number->string (+ a b))}
		  @p{@hellip is the answer}
		}
	      }
	      @,@common-foot
	    }
	  }))
      (make-error-response
       400 "Don't know how to perform the requested calculation.")))

(webgate-main)