;; -*- 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") "")))) (tr (td "PATH_INFO") (td (code ,(or (getenv "PATH_INFO") "")))) (tr (td "REQUEST_METHOD") (td (code ,(or (getenv "REQUEST_METHOD") "")))))) } } } @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)