;; -*- 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)