brmlab/brmelect
9
0
Fork 0
forked from brmlab/brmelect-github
Code Pull requests Activity

2025 version

Browse source
This commit is contained in:
TMA 2026-03-13 22:12:20 +01:00
parent 1d1468d87f
commit ee4de955de
13 changed files with 2025 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

6
.gitignore vendored Normal file
View file

@ -0,0 +1,6 @@
*~
.*.sw?
*.o
*.link
/eggs/
*.import.scm

52
Makefile Normal file
View file

@ -0,0 +1,52 @@
#
# Makefile
#
# Wrapper for src/
#
# ISC License
#
# Copyright 2023 Brmlab, z.s.
# Dominik Pantůček <dominik.pantucek@trustica.cz>
#
# Permission to use, copy, modify, and/or distribute this software
# for any purpose with or without fee is hereby granted, provided
# that the above copyright notice and this permission notice appear
# in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
# WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
# AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
# CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
# OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
# CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#
.PHONY: default
default:
@make -C src
.PHONY: static
static:
@make -C src static
.PHONY: clean
clean:
@make -C src clean
.PHONY: install
install:
@make -C src install
.PHONY: install-dev
install-dev:
@make -C src install-dev
.PHONY: gendoc
gendoc:
@make -C src gendoc
.PHONY: doc
doc: gendoc
@./gendoc

71
install-eggs.sh Normal file
View file

@ -0,0 +1,71 @@
#!/bin/sh
#
# install-eggs.sh
#
# Local installer of CHICKEN eggs required for building.
#
# ISC License
#
# Copyright 2023 Brmlab, z.s.
# Dominik Pantůček <dominik.pantucek@trustica.cz>
# Copyright 2025 Brmlab, z.s.
# TMA
#
# Permission to use, copy, modify, and/or distribute this software
# for any purpose with or without fee is hereby granted, provided
# that the above copyright notice and this permission notice appear
# in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
# WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
# AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
# CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
# OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
# CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#
# Source root directory
owd=$(pwd)
cd $(dirname "$0")
SRCDIR=$(pwd)
cd "$owd"
# Make temporary prefix directory (eggs shared throwaway files)
TMPDIR=$(mktemp -d)
# Installs given egg locally
chicken_install() {
echo "Installing $1 ..."
CHICKEN_INSTALL_PREFIX="$TMPDIR" \
CHICKEN_REPOSITORY_PATH="$SRCDIR/eggs":`chicken-install -repository` \
CHICKEN_INSTALL_REPOSITORY="$SRCDIR/eggs" \
chicken-install "$1" 2>&1 | \
sed -u 's/^/ /'
}
# Removes throwaway files
chicken_cleanup() {
echo "Cleaning up ..."
rm -fr ${TMPDIR}
}
# Always cleanup
trap chicken_cleanup INT QUIT
# Install required eggs
chicken_install sqlite3
chicken_install srfi-1
chicken_install regex
chicken_install srfi-13
chicken_install srfi-18
chicken_install srfi-69
#chicken_install srfi-98 #builtin
chicken_install srfi-99
chicken_install miscmacros
chicken_install cairo
chicken_install crypt
# Normal termination cleanup
chicken_cleanup

95
src/Makefile Normal file
View file

@ -0,0 +1,95 @@
#
# Makefile
#
# Building the project.
#
# ISC License
#
# Copyright 2023 Brmlab, z.s.
# Dominik Pantůček <dominik.pantucek@trustica.cz>
# Copyright 2025 Brmlab, z.s.
# TMA
#
# Permission to use, copy, modify, and/or distribute this software
# for any purpose with or without fee is hereby granted, provided
# that the above copyright notice and this permission notice appear
# in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
# WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
# AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
# CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
# OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
# CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#
BRMELECT-BIN = ../brmelect.pl
.PHONY: default
default: imports
.PHONY: static
static: $(BRMELECT-BIN)
# Uses local repository first, then system. Be sure to run
# install-eggs.sh in the parent directory first!
SCRP=$(shell chicken-install -repository)
CSC=CHICKEN_REPOSITORY_PATH=../eggs:$(SCRP) csc
BRMELECT-DEPS=brmelect.scm webgate-utils.import.scm webgate-core.import.scm
brmelect.scm.X = -X at-expr-on.scm
BRMELECT-OBJS=brmelect.o webgate-core.o webgate-utils.o
.PHONY: imports
imports: $(BRMELECT-DEPS)
$(BRMELECT-BIN): $(BRMELECT-OBJS)
$(CSC) -L --no-lto -L -Wl,-static -L -Wl,-lsqlite3 -L -Wl,-Bdynamic -strip -static -o $@ $(BRMELECT-OBJS)
chmod u+s $@
.PHONY: clean
clean:
rm -f *.c *.link *.o *.import.scm $(BRMELECT-BIN)
.PHONY: install
install: static
#install -m 0755 -d /usr/local/bin
#install -m 0755 $(BRMELECT-BIN) /usr/local/bin/
#install -m 0755 -d /usr/local/man/man1
#install -m 0755 ../doc/brmelect.1 /usr/local/man/man1/brmelect.1
.PHONY: install-dev
install-dev: static
#install -m 0755 -d /usr/local/bin
#install -m 0755 $(BRMELECT-BIN) /usr/local/bin/brmelect-dev
#install -m 0755 -d /usr/local/man/man1
#install -m 0755 ../doc/brmelect.1 /usr/local/man/man1/brmelect-dev.1
################################################################
# Module static and shared object and import source compilation
%.o: %.scm
$(CSC) $($<.X) -c -static $<
%.import.scm: %.scm
$(CSC) $($<.X) -regenerate-import-libraries -P -J $<
################################################################
# Main programs
brmelect.o: $(BRMELECT-DEPS)
################################################################
# Modules
WEBGATE-CORE-SOURCES=webgate-core.scm
webgate-core.o: webgate-core.import.scm
webgate-core.import.scm: $(WEBGATE-CORE-SOURCES)
WEBGATE-UTILS-SOURCES=webgate-utils.scm
webgate-utils.o: webgate-utils.import.scm
webgate-utils.import.scm: $(WEBGATE-UTILS-SOURCES)

2
src/at-expr-on.scm Normal file
View file

@ -0,0 +1,2 @@
(import (only webgate-utils use-at-read-table))
(use-at-read-table #:list-arguments? #t)

113
src/brmelect.scm Normal file
View file

@ -0,0 +1,113 @@
;;#!/usr/bin/env csi -s
;; Import necessary modules for CGI handling
;(use posix)
;(use srfi-19) ; For basic string manipulation
(import scheme
(chicken base)
(chicken format)
;(chicken miscmacros)
miscmacros
sqlite3
webgate-core
;configuration
)
(import-for-syntax
srfi-1
webgate-core)
;(eval-when (eval)
;(cond-expand
; (chicken
; (begin
; (import (only webgate-utils use-at-read-table))
; (use-at-read-table #:list-arguments? #t)))
; ;(else #f)
; )
;; Thread-local parameter to re-use SQLite3 DB handle for subsequent queries
(define *cached-brmelect-db* (make-parameter #f))
(define =brmelect-db-path= "/home/brmelect/brmelect/brmelect.sqlite3")
;; Returns (possibly cached) SQLite3 DB handle
(define (brmelect-db)
(let ((cdb (*cached-brmelect-db*)))
(if cdb
cdb
(begin
(*cached-brmelect-db*
(let ((handler (make-busy-timeout 2000)))
(let ((db (open-database =brmelect-db-path=)))
(set-busy-handler! db handler)
db)))
(*cached-brmelect-db*)))))
(define (initialize-db)
(let ((db (brmelect-db)))
;; admin passwords
(execute db "create table if not exists admins (login text not null primary key, password text not null)")
;; GA
(execute db "create table if not exists general_assemblies (id integer primary key, ga_date text not null, ga_open integer not null)")
(execute db "insert or ignore into general_assemblies (id, ga_date, ga_open) values (17, '2025-01-21', 1)")
;; elections
(execute db "create table if not exists elections (id integer primary key autoincrement, ga_id integer not null, election_name text not null, election_running integer not null, election_file text not null, foreign key (ga_id) references general_assemblies(id))")
;; candidates
(execute db "create table if not exists candidates (id integer primary key autoincrement, election_id integer not null, candidate_name text not null, candidate_nick text not null, foreign key (election_id) references elections(id)")
))
(initialize-db)
(define-resource (root* parameters)
(make-html-response
200
;@li{@a[(href ,(resource-uri calc "add"))]{Suspensions}}
;@,common-head
`@html{
@head{
@title{foo}
}
@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}}
}
}
}
}
}
}
}))
(define brmelect-style
"p, li { font-family: monospace; }
#ballot { margin-left: auto; margin-right: auto; border: 1pt solid; width: 20em; padding: 1ex 1em; }
.error { text-width: bold; color: red }
#blurb { margin: 8ex 2em; }
table { margin-left: auto; margin-right: auto; border: 1pt solid; border-collapse: collapse; }
td { border: 1pt solid; padding: 0.5ex 0.5em; }")
(define-resource (elect "elect" parameters)
(make-html-response
200
`@html{
@head{@title{brmelect Web Ballot}
@style[(type "text/css")]{@,brmelect-style}}
@body{
}}))
(define-resource (elect "elect" "config" parameters)
(make-html-response
200
`@html{
@head{@title{brmelect web config}}
@body{
}}))
(cgi-main-loop handle-request)

328
src/example.scm Normal file
View file

@ -0,0 +1,328 @@
;; -*- mode: Scheme; -*-
;; https://chust.org/repos/chicken-webgate/file?name=example.scm&ci=tip
;;
;; 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>"))))
(tr (td "REMOTE_ADDR")
(td (code ,(or (getenv "REMOTE_ADDR") "<unknown>"))))
(tr (td "REMOTE_PORT")
(td (code ,(or (getenv "REMOTE_PORT") "<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-2015 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)
;;This page was generated in about 0.01s by Fossil 2.24 [8be0372c10] 2024-04-23 13:25:26

97
src/suspension.scm Normal file
View file

@ -0,0 +1,97 @@
;; -*- mode: Scheme; -*-
;; https://chust.org/repos/chicken-webgate/file?name=suspension.scm&ci=tip
;;
;; This file is distributed with WebGate for CHICKEN.
;; Copyright (c) 2006-2010 by Felix L. Winkelmann. All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above
;; copyright notice, this list of conditions and the following
;; disclaimer in the documentation and/or other materials provided
;; with the distribution.
;;
;; 3. The name of the authors may not be used to endorse or promote
;; products derived from this software without specific prior
;; written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(require-library srfi-18 ports protobuf)
(declare (disable-interrupts))
(module suspension
(with-limited-continuation
continuation-drop
continuation-suspend
continuation-resume)
(import
scheme chicken
srfi-18 ports (only protobuf-generic serialize deserialize))
(define error-output ##sys#standard-error)
(define standard-output ##sys#standard-output)
(define standard-input ##sys#standard-input)
(define (exception-handler ex)
(thread-signal! (thread-specific ##sys#current-thread) ex)
(continuation-drop #f) )
(define (with-limited-continuation thunk)
(let* ((t (make-thread
(lambda ()
(##sys#call-with-cthulhu
(lambda ()
(##sys#call-with-values thunk continuation-drop) ) ) ) ) )
(state (##sys#slot t 5)) )
(##sys#setislot state 0 '())
(##sys#setslot state 1 standard-input)
(##sys#setslot state 2 standard-output)
(##sys#setslot state 3 error-output)
(##sys#setslot state 4 exception-handler)
(thread-specific-set! t ##sys#current-thread)
(thread-start! t)
(thread-suspend! ##sys#current-thread)
(##sys#setslot (##sys#slot t 5) 5 (##sys#slot state 5))
(##sys#apply-values (##sys#slot t 2)) ) )
(define (continuation-drop . results)
(##sys#setslot ##sys#current-thread 2 results)
(thread-resume! (thread-specific ##sys#current-thread))
(##sys#thread-kill! ##sys#current-thread 'dead)
(##sys#schedule) )
(define (continuation-suspend store)
(##sys#apply-values
(##sys#call-with-direct-continuation
(lambda (k)
(let ((o (open-output-string)))
(serialize k o)
(##sys#call-with-values
(lambda () (store (get-output-string o)))
continuation-drop) ) ) ) ) )
(define (continuation-resume k . results)
(##sys#direct-return (with-input-from-string k deserialize) results) )
)
;;This page was generated in about 0.008s by Fossil 2.24 [8be0372c10] 2024-04-23 13:25:26

36
src/volitelni.awk Normal file
View file

@ -0,0 +1,36 @@
#!/bin/awk -f
# vh_number=17; hackerbase -sheet /dev/stdout $vh_number -quiet |
BEGIN {
FS=" *& *";
OFS=",";
print "create table if not exists members (";
print "id integer primary key not null,";
print "nick text not null,";
print "name text not null,";
print "surname text not null,";
print "in_debt integer not null,";
print "short_tenure integer not null,";
print "eligible integer not null);";
print "insert into members"
print "(id,nick,name,surname,in_debt,short_tenure,eligible) values";
valsep="(";
}
{
dluh=1;
kratky=1;
gsub(/\\small */,"")
gsub(/\\_/,"_")
}
/Bez.dluhu/ { dluh=0; }
/9\/12/ { kratky = 0; }
/1[012]\/12/ { kratky = 0; }
/^[0-9][0-9][0-9][0-9] / {
print valsep $1,"'" $2 "'","'" $3 "'","'" $4 "'",dluh,kratky,!(dluh||kratky) ")";
valsep=",("
}
END {
print ";";
}

10
src/volitelni.txt Normal file
View file

@ -0,0 +1,10 @@
dzoe> TMA: co chces na tom vypise volitelnych?
TMA> to, co se tiskne na volebni listky: jmeno, nick
dzoe> TMA: hackerbase -sheet /dev/stdout 17 -quiet | egrep '^[0-9]{4} '|egrep 'Bez.dluhu'|egrep '9/12|10/12|11/12|12/12'|awk
'BEGIN{FS=" *& *";OFS=","}{print $1,$2,$3,$4}'|sed 's/[\\]small *//g'
dzoe> IMHO ten oneliner, co jsem pastnul, vygeneruje pricetne CSV, pro potreby generovani volebnich listku - ale samozrejme
idealne by to rovnou generovalo PDF(ka).
TMA> dzoe: jako kdo musim byt prihlasen, aby to chodilo?
dzoe> No, jako hackerbase@brmlab.cz
TMA> ok

552
src/webgate-core.scm Normal file
View file

@ -0,0 +1,552 @@
;; -*- mode: Scheme; -*-
;; modified for chicken 5 and brmelect
;; Copyright (c) 2011-2013 by TMA. All rights reserved.
;; https://chust.org/repos/chicken-webgate/file?name=webgate-core.scm&ci=tip
;; 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.
;;; Message base type
(declare (unit webgate-core))
(module webgate-core
(message make-message message?
message-type message-headers message-body message-text
write-message
max-request-size
request-method-handler
request-body-handler
request-parameter-handler
parameter-list-ref parameter-ref
resource-context current-resource-context resource-context?
resource-context-getenv resource-context-method resource-context-path
response make-response response?
collect-response make-html-response make-error-response
make-redirect-response
response-status response-status-message
write-response
resource-handler resource-uri
(define-resource resource-handler extend-procedure procedure-data)
handle-query-parameters
handle-request
cgi-main-loop)
(import
scheme
(chicken base)
(chicken format)
(chicken string)
(chicken port)
(chicken io)
(chicken memory representation)
(chicken time)
;(chicken continuation)
(chicken condition)
srfi-1
srfi-4
srfi-13
srfi-18
srfi-69
srfi-98
srfi-99
;data-structures extras lolevel
(chicken irregex)
;suspension
webgate-utils
)
(define-record-type message
%make-message #t
type headers
body)
(define (make-message
body #!key
(type "application/octet-stream") (headers '()))
(%make-message type headers body))
(define message-text
(let ((text/plain-rx (irregex '(: bos "text/plain" (or ";" eos)))))
(lambda (msg)
(and (irregex-search text/plain-rx (message-type msg))
(message-body msg)))))
(define (write-message msg #!optional (port (current-output-port)))
(let ((type (message-type msg))
(body (message-body msg)))
(when type
(fprintf port "Content-type: ~a\r\n" type))
(when body
(fprintf port "Content-length: ~a\r\n" (string-length body)))
(for-each
(lambda (header)
(call-with-values (cut car+cdr header)
(cut fprintf port "~a: ~a\r\n" <> <>)))
(message-headers msg))
(display "\r\n" port)
(when body
(display body port))))
;;; Request processing infrastructure
(define max-request-size
(make-parameter #xffff))
(define-values (request-method-handler handled-request-methods)
(let ((handlers (make-hash-table #:test string-ci=? #:hash string-ci-hash)))
(values
(case-lambda
((name)
(hash-table-ref/default handlers name #f))
((name proc)
(hash-table-set! handlers name proc)))
(cut hash-table-keys handlers))))
(define request-body-handler
(let ((handlers (make-hash-table #:test string-ci=? #:hash string-ci-hash)))
(case-lambda
((name)
(hash-table-ref/default handlers name #f))
((name proc)
(hash-table-set! handlers name proc)))))
(define request-parameter-handler
(let ((handler
(lambda (parameters key msg)
(hash-table-update!/default
parameters key (cut append! <> (list msg)) '()))))
(case-lambda
(()
handler)
((proc)
(set! handler proc)))))
(define (parameter-list-ref parameters key #!optional (convert message-text))
(map convert (hash-table-ref/default parameters key '())))
(define (parameter-ref parameters key #!optional (convert message-text))
(and-let* ((vs (hash-table-ref/default parameters key '()))
((pair? vs)))
(convert (car vs))))
;;; Response processing infrastructure
(define-record-type resource-context
%make-resource-context #t
getenv method path)
(define current-resource-context
(make-parameter #f))
(define status-table
(alist->hash-table
'((100 . "Continue")
(101 . "Switching Protocols")
(200 . "Ok")
(201 . "Created")
(202 . "Accepted")
(203 . "Non-Authoritative Information")
(204 . "No Content")
(205 . "Reset Content")
(206 . "Partial Content")
(300 . "Multiple Choices")
(301 . "Moved Permanently")
(302 . "Found")
(303 . "See Other")
(304 . "Not Modified")
(305 . "Use Proxy")
(307 . "Temporary Redirect")
(400 . "Bad Request")
(401 . "Unauthorized")
(402 . "Payment Required")
(403 . "Forbidden")
(404 . "Not Found")
(405 . "Method Not Allowed")
(406 . "Not Acceptable")
(407 . "Proxy Authentication Required")
(408 . "Request Timeout")
(409 . "Conflict")
(410 . "Gone")
(411 . "Length Required")
(412 . "Precondition Failed")
(413 . "Request Entity Too Large")
(414 . "Request-URI Too Long")
(415 . "Unsupported Media Type")
(416 . "Requested Range Not Satisfiable")
(417 . "Expectation Failed")
(500 . "Internal Server Error")
(501 . "Not Implemented")
(502 . "Bad Gateway")
(503 . "Service Unavailable")
(504 . "Gateway Timeout")
(505 . "HTTP Version Not Supported"))
#:test = #:hash number-hash))
(define-record-type (response message)
%make-response #t
status status-message)
(define (make-response
status body #!key
(type (and body "application/octet-stream"))
(headers '())
(status-message
(hash-table-ref/default status-table status "Unknown")))
(%make-response
type headers body
status status-message))
(define (collect-response
status thunk #!key
(type "application/octet-stream")
(headers '())
(status-message
(hash-table-ref/default status-table status "Unknown")))
(%make-response
type headers (with-output-to-string thunk)
status status-message))
(define (make-html-response
status html #!key
(status-message
(hash-table-ref/default status-table status "Unknown"))
(headers '()))
(%make-response
"text/html" headers (call-with-output-string (cut write-html html <>))
status status-message))
(define (make-error-response
status message #!key
(status-message
(hash-table-ref/default status-table status "Unknown"))
(headers '()))
(make-html-response
status
(let ((status-line (sprintf "~a ~a" status status-message)))
`(html
(head
(meta ((name "robots") (content "noindex")))
(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))
(define resource-handler
(let ((handlers (make-hash-table)))
(case-lambda
((path)
(let next ((handlers handlers) (args '()) (path path))
(if (pair? path)
(let-values (((step path) (car+cdr path)))
(cond
((hash-table-ref/default handlers step #f)
=> (cut next <> args path))
((hash-table-ref/default handlers #f #f)
=> (cut next <> (cons step args) path))
(else
#f)))
(cond
((hash-table-ref/default handlers #t #f)
=> (lambda (proc)
(lambda (parameters)
(apply proc (reverse! (cons* parameters args))))))
(else
#f)))))
((path proc)
(let next ((handlers handlers) (path path))
(if (pair? path)
(let-values (((step path) (car+cdr path)))
(hash-table-update!
handlers step (cut next <> path) make-hash-table))
(hash-table-set! handlers #t proc))
handlers)
(void)))))
(define-syntax define-resource
(syntax-rules ()
((define-resource (name step/arg ... parameters)
expr ...)
(begin
(define name
(let-syntax ((path
(ir-macro-transformer
(lambda (stx inject id=?)
(let ((steps (cdr stx)))
`(list ,@(map
(lambda (step)
(and (string? step) step))
steps))))))
(path-lambda
(ir-macro-transformer
(lambda (stx inject id=?)
(let ((steps (cadr stx))
(body (cddr stx)))
`(lambda ,(filter-map
(lambda (step)
(and (symbol? step) step))
steps)
,@body))))))
(extend-procedure
(path-lambda (step/arg ... parameters)
expr ...)
(path step/arg ...))))
(resource-handler (procedure-data name) name)))))
(define (write-uri-step step port)
(fprintf port "/~a" (uri-encode step)))
(define (resource-uri res . args)
(call-with-output-string
(lambda (port)
(for-each
(cut write-uri-step <> port)
(string-split
(or ((resource-context-getenv (current-resource-context)) "SCRIPT_NAME")
"")
"/"))
(let next ((steps (procedure-data res)) (args args))
(if (pair? steps)
(let-values (((step steps) (car+cdr steps)))
(if step
(begin
(write-uri-step step port)
(next steps args))
(if (pair? args)
(let-values (((arg args) (car+cdr args)))
(write-uri-step arg port)
(next steps args))
(error 'resource-uri "too few arguments"))))
(unless (null? args)
(error 'resource-uri "too many arguments" args)))))))
;;; Pre-installed default handlers (and directly related stuff)
(define (handle-query-parameters parameters query)
(for-each
(lambda (key+value)
(let-optionals (map uri-decode (string-split key+value "="))
((key #f) (value ""))
(when key
((request-parameter-handler)
parameters key
(make-message value #:type "text/plain")))))
(string-split query "&;"))
#f)
(request-body-handler "application/x-www-form-urlencoded"
(lambda (parameters type size port)
(handle-query-parameters parameters (read-string size port))))
(request-body-handler "multipart/form-data"
(letrec ((boundary-rx
(irregex '(: bow "boundary=" ($ (+ (~ (" ;\n\r\t")))))))
(multipart-boundary
(lambda (s)
(cond
((irregex-search boundary-rx s)
=> (cut irregex-match-substring <> 1))
(else
#f))))
(header-rx
(irregex '(: ($ (+ (~ #\:))) #\: (* space) ($ (*? any))
(or "\r\n" eos))))
(special+regular-headers
(lambda (s start end special)
(partition
(lambda (key+value)
(member (car key+value) special string-ci=?))
(irregex-fold
header-rx
(lambda (start m seed)
(cons (cons (irregex-match-substring m 1)
(irregex-match-substring m 2))
seed))
'() s
(lambda (start seed)
(reverse! seed))
start end))))
(name-rx
(irregex '(: bow "name=" #\" ($ (*? (~ #\"))) #\")))
(disposition-name
(lambda (s default)
(cond
((irregex-search name-rx s)
=> (cut irregex-match-substring <> 1))
(else
default))))
(handle-messages
(lambda (parameters name data boundary)
(let ((boundary-rx
(irregex `(: (or bos "\r\n") "--"
,boundary
(? "--") "\r\n"))))
(irregex-fold
boundary-rx
(lambda (start m skip?)
(and-let* (((not skip?))
(end
(irregex-match-start-index m))
(header-end
(string-contains data "\r\n\r\n" start end))
(body
(substring/shared data (+ header-end 4) end)))
(let-values (((specials headers)
(special+regular-headers
data start header-end
'("Content-type" "Content-length"))))
(let ((type
(alist-ref
"Content-type" specials string-ci=?
"text/plain"))
(name
(disposition-name
(alist-ref
"Content-disposition" headers string-ci=?)
name)))
(when name
(cond
((multipart-boundary type)
=> (cut handle-messages parameters name body <>))
(else
((request-parameter-handler)
parameters name
(make-message
body #:type type #:headers headers))))))))
#f)
#t data))
#f)))
(lambda (parameters type size port)
(cond
((multipart-boundary type)
=> (cut handle-messages
parameters #f (read-string size port) <>))
(else
(make-error-response
501 "The server doesn't know how to parse request parameters from the content type sent."))))))
(request-method-handler "GET"
(lambda (parameters method getenv port)
(handle-query-parameters parameters (or (getenv "QUERY_STRING") ""))))
(request-method-handler "POST"
(lambda (parameters method getenv port)
(or
(handle-query-parameters parameters (or (getenv "QUERY_STRING") ""))
(let ((type (or
(getenv "CONTENT_TYPE")
"application/octet-stream"))
(size (cond
((getenv "CONTENT_LENGTH")
=> string->number)
(else
#f))))
(cond
((not size)
(make-error-response
411 "The server refuses processing as no content length was sent with the request."))
((cond ((max-request-size) => (cut > size <>)) (else #f))
(make-error-response
413 "The server refuses processing as the request's content length is too large."))
((request-body-handler (substring/shared
type 0 (or (string-index type #\;)
(string-length type))))
=> (cut <> parameters type size port))
(else
(make-error-response
501 "The server doesn't know how to parse request parameters from the content type sent.")))))))
;;; FIXME: thread magic could replace this:
(define (with-limited-continuation thunk)
(thunk))
;;; CGI server "loop"
(define (cgi-main-loop handle-request)
(handle-request
get-environment-variable
(current-input-port) (cute write-response <> (current-output-port))))
;;; Central server routine
(define (handle-request getenv input-port write-response)
(write-response
(handle-exceptions
exn (begin
(when (uncaught-exception? exn)
(set! exn (uncaught-exception-reason exn)))
(fprintf (current-output-port) "Content-type: text/plain\r\nConnection: close\r\n\r\n")
(print-error-message
exn (current-output-port)
(sprintf "[~a] Request Handling Error" (current-seconds)))
(print-call-chain)
(make-error-response
500 "The server encountered an internal error handling the request."))
(let ((parameters (make-hash-table))
(method (or (getenv "REQUEST_METHOD") "GET"))
(path (string-split (uri-decode (or (getenv "PATH_INFO") (getenv "SCRIPT_URL") "")) "/")))
(or
(cond
((request-method-handler method)
=> (cut <> parameters method getenv input-port))
(else
(make-error-response
405 "The access method used to request the document is not supported."
#:headers
(list
(cons "Allow" (string-join (handled-request-methods) ", "))))))
(cond
((resource-handler path)
=> (lambda (proc)
(with-limited-continuation
(lambda ()
(current-resource-context
(%make-resource-context getenv method path))
(proc parameters)))))
(else
(make-error-response
404 "The requested resource was not found by the server.")))
(make-response 204 '()))))))
)

468
src/webgate-utils.scm Normal file
View file

@ -0,0 +1,468 @@
;; -*- mode: Scheme; -*-
;;
;; modified for chicken 5 and brmelect
;; Copyright (c) 2011-2013 by TMA. All rights reserved.
;; https://chust.org/repos/chicken-webgate/file?name=webgate-utils.scm&ci=tip
;;
;; 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.
;;; Compression
(declare (unit webgate-utils))
(module webgate-utils
(#;compress #;decompress
write-netstring read-netstring
make-at-reader make-at-read-table use-at-read-table
uri-encode uri-decode
base64-encode base64-decode
write-html)
(import
scheme
(chicken base)
;(chicken foreign)
(chicken io)
(chicken format)
(chicken fixnum)
(chicken syntax)
(chicken keyword)
(chicken read-syntax)
srfi-1 srfi-13 srfi-14 srfi-69
;(except data-structures compress) extras
(chicken irregex))
(import-for-syntax srfi-1)
#;(foreign-declare
"#include <bzlib.h>")
#;(define (compress idata #!optional [level 9])
(let* ((isize (string-length idata))
(odata (make-string (inexact->exact (round (+ 600 (* 1.01 isize)))))))
(let-location ((osize unsigned-int (string-length odata)))
(if ((foreign-lambda* bool ((scheme-pointer odata) ((c-pointer unsigned-int) osize)
(scheme-pointer idata) (unsigned-int isize) (int level))
"C_return(BZ2_bzBuffToBuffCompress(odata, osize, idata, isize, level, 0, 0) == BZ_OK);")
odata (location osize) idata isize level)
(substring odata 0 osize)
(error 'compress "Data compression error")))))
#;(define (decompress idata)
(let ((isize (string-length idata)))
(let retry ((odata (make-string (* 2 isize))))
(let-location ((osize unsigned-int (string-length odata)))
(case ((foreign-lambda* int ((scheme-pointer odata) ((c-pointer unsigned-int) osize)
(scheme-pointer idata) (unsigned-int isize))
"switch (BZ2_bzBuffToBuffDecompress(odata, osize, idata, isize, 0, 0)) {\n"
"case BZ_OK: C_return(0);\n"
"case BZ_OUTBUFF_FULL: C_return(1);\n"
"default: C_return(2);\n"
"}\n")
odata (location osize) idata isize)
((0) (substring odata 0 osize))
((1) (retry (make-string (* 2 osize))))
(else (error 'decompress "Data decompression error")))))))
;;; Netstrings
(define (write-netstring s #!optional (port (current-output-port)))
(fprintf port "~a:~a," (string-length s) s))
(define (read-netstring #!optional (port (current-input-port)))
(let ((l (string->number (read-token char-numeric? port))))
(unless l
(error
'read-netstring
"client side protocol error: malformed netstring (bad length)"))
(unless (eq? (read-char port) #\:)
(error
'read-netstring
"client side protocol error: malformed netstring (bad delimiter)"))
(let ((s (read-string l port)))
(unless (eq? (read-char port) #\,)
(error
'read-netstring
"client side protocol error: malformed netstring (bad terminal)"))
s)))
;;; @-expressions
(define (make-at-reader+table args)
(letrec* ((command-char
(get-keyword #:command-char args (constantly #\@)))
(trim-whitespace?
(get-keyword #:trim-whitespace? args (constantly #t)))
(condense-whitespace?
(get-keyword #:condense-whitespace? args (constantly #t)))
(list-arguments?
(get-keyword #:list-arguments? args (constantly #f)))
(char-normal?
(cute char-set-contains?
(char-set-complement
(char-set command-char #\{ #\} #\return #\newline))
<>))
(char-group?
(cute char-set-contains?
(char-set #\[ #\{)
<>))
(skip-whitespace
(lambda (port)
(when (char-whitespace? (peek-char port))
(read-char port)
(skip-whitespace port))))
(read-whitespace
(if condense-whitespace?
(lambda (port)
(skip-whitespace port)
" ")
(cut read-token char-whitespace? <>)))
(read-datum
(lambda (port)
(parameterize ((current-read-table datum-read-table))
(read port))))
(read-at-exp
(lambda (port)
(skip-whitespace port)
(let ((char (peek-char port)))
(cond
((eof-object? char)
(read-char port))
(else
(when (eqv? char command-char)
(read-char port))
(let* ((head (and (not (char-group? (peek-char port)))
(read-datum port)))
(args (and (eqv? (peek-char port) #\[)
(read-datum port)))
(body (and (eqv? (peek-char port) #\{)
(read-inside-at-exp 'skip port))))
(if (or args body)
(append!
(cond
(head => list)
(else '()))
(cond
((and list-arguments? args) => list)
(else (or args '())))
(or body '()))
head)))))))
(read-inside-at-exp
(lambda (brace-mode port)
(append!
(let ((head
(case brace-mode
((none)
'())
((skip)
(and (eqv? (peek-char port) #\{)
(begin (read-char port) '())))
(else
(and (eqv? (peek-char port) #\{)
(list (string (read-char port))))))))
(if head
(begin
(when trim-whitespace? (skip-whitespace port))
head)
(syntax-error
'read-inside-at-exp "expected @-expression body, found"
(peek-char port))))
(let more ()
(let ((char (peek-char port)))
(cond
((eqv? char #\{)
(case brace-mode
((none)
(cons (string (read-char port)) (more)))
(else
(append! (read-inside-at-exp 'keep port) (more)))))
((eqv? char #\})
(case brace-mode
((none)
(cons (string (read-char port)) (more)))
((skip)
(read-char port)
'())
(else
(list (string (read-char port))))))
((eof-object? char)
(case brace-mode
((none)
(read-char port)
'())
(else
(syntax-error
'read-inside-at-exp "@-expression body not closed"))))
((eqv? char command-char)
(cons (read-at-exp port) (more)))
((char-whitespace? char)
(let* ((head (read-whitespace port))
(tail (more)))
(if (or (pair? tail) (not trim-whitespace?))
(cons head tail)
tail)))
(else
(cons (read-token char-normal? port) (more)))))))))
(read-table
(get-keyword #:read-table args current-read-table))
(at-read-table
(parameterize ((current-read-table (copy-read-table read-table)))
(set-read-syntax! command-char read-at-exp)
(current-read-table)))
(datum-read-table
(let ((spec (get-keyword #:datum-read-table args (constantly #t))))
(cond
((procedure? spec)
(spec at-read-table))
(spec
at-read-table)
(else
read-table)))))
(values
(if (get-keyword #:inside? args)
(lambda (#!optional (port (current-input-port)))
(read-inside-at-exp 'none port))
(lambda (#!optional (port (current-input-port)))
(read-at-exp port)))
at-read-table)))
(define (make-at-reader . args)
(nth-value 0 (make-at-reader+table args)))
(define (make-at-read-table . args)
(nth-value 1 (make-at-reader+table args)))
(define (use-at-read-table . args)
(current-read-table (nth-value 1 (make-at-reader+table args))))
;;; URI encoding
(define uri-encode
(let ((problematic-rx (irregex '(~ (or alphanumeric "-._~")))))
(lambda (s)
(irregex-replace/all
problematic-rx s
(lambda (m)
(string-append
"%"
(string-pad
(number->string
(char->integer (string-ref (irregex-match-substring m) 0)) 16)
2 #\0)))))))
(define uri-decode
(let ((escape-rx (irregex '(or #\+ (: #\% ($ (= 2 hex-digit)))))))
(lambda (s)
(irregex-replace/all
escape-rx s
(lambda (m)
(case (string-ref s (irregex-match-start-index m))
((#\+)
" ")
((#\%)
(string
(integer->char
(string->number (irregex-match-substring m 1) 16))))))))))
;;; Base64URI encoding
(define base64-alphabet
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(define base64-alphabet/uri
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
(define (base64-encode s #!optional uri-safe?)
(let* ((alphabet (if uri-safe? base64-alphabet/uri base64-alphabet))
(n (string-length s))
(e (make-string (inexact->exact (ceiling (* 4/3 n))))))
(do ((is 0 (fx+ is 3)) (ie 0 (fx+ ie 4))) ((fx>= is n) e)
(let ((i (fxior
(fxshl (char->integer (string-ref s is)) 16)
(if (fx< (fx+ is 1) n)
(fxior
(fxshl (char->integer (string-ref s (fx+ is 1))) 8)
(if (fx< (fx+ is 2) n)
(char->integer (string-ref s (fx+ is 2)))
0))
0))))
(string-set!
e ie
(string-ref alphabet (fxand (fxshr i 18) #b111111)))
(string-set!
e (fx+ ie 1)
(string-ref alphabet (fxand (fxshr i 12) #b111111)))
(when (fx< (fx+ is 1) n)
(string-set!
e (fx+ ie 2)
(string-ref alphabet (fxand (fxshr i 6) #b111111)))
(when (fx< (fx+ is 2) n)
(string-set!
e (fx+ ie 3)
(string-ref alphabet (fxand i #b111111)))))))))
(define base64-decode
(let ((alphabet-ref
(let* ((n (string-length base64-alphabet))
(alphabet (make-hash-table eqv? eqv?-hash (fx+ n 2))))
(do ((i 0 (fx+ i 1))) ((fx>= i n))
(hash-table-set! alphabet (string-ref base64-alphabet i) i))
(do ((i (fx- n 2) (fx+ i 1))) ((fx>= i n))
(hash-table-set! alphabet (string-ref base64-alphabet/uri i) i))
(lambda (chr)
(hash-table-ref
alphabet chr
(cut syntax-error 'base64-decode "illegal character" chr))))))
(lambda (e)
(let* ((n (string-length e))
(s (make-string (inexact->exact (floor (* 3/4 n))))))
(do ((ie 0 (fx+ ie 4)) (is 0 (fx+ is 3))) ((fx>= ie n) s)
(let ((i (fxior
(fxshl
(alphabet-ref (string-ref e ie)) 18)
(if (fx< (fx+ ie 1) n)
(fxior
(fxshl
(alphabet-ref (string-ref e (fx+ ie 1))) 12)
(if (fx< (fx+ ie 2) n)
(fxior
(fxshl
(alphabet-ref (string-ref e (fx+ ie 2))) 6)
(if (fx< (fx+ ie 3) n)
(alphabet-ref (string-ref e (fx+ ie 3)))
0))
0))
0))))
(string-set!
s is (integer->char (fxand (fxshr i 16) #xff)))
(when (fx< (fx+ ie 2) n)
(string-set!
s (fx+ is 1) (integer->char (fxand (fxshr i 8) #xff)))
(when (fx< (fx+ ie 3) n)
(string-set!
s (fx+ is 2) (integer->char (fxand i #xff)))))))))))
;;; HTML output
(define write-html
(letrec ((tag-rules
(alist->hash-table
'((area . void)
(base . void)
(br . void)
(col . void)
(command . void)
(embed . void)
(hr . void)
(img . void)
(input . void)
(keygen . void)
(link . void)
(meta . void)
(param . void)
(source . void)
(track . void)
(wbr . void)
(script . raw)
(style . raw))
#:test eq? #:hash eq?-hash))
(problematic-rx
(irregex '("\"&<>")))
(html-escape
(lambda (s)
(irregex-replace/all
problematic-rx s
(lambda (m)
(case (string-ref (irregex-match-substring m) 0)
((#\") "&quot;")
((#\&) "&amp;")
((#\<) "&lt;")
((#\>) "&gt;"))))))
(write-element
(lambda (elt port)
(unless (and (pair? elt) (symbol? (car elt)) (list? (cdr elt)))
(error
'write-html "not a proper element"
elt))
(let-values (((tag attributes+contents)
(car+cdr elt)))
(fprintf port "<~a" tag)
(let-values (((rule)
(hash-table-ref/default tag-rules tag 'normal))
((attributes contents)
(cond
((null? attributes+contents)
(values '() '()))
((and (list? (car attributes+contents))
(every list? (car attributes+contents)))
(car+cdr attributes+contents))
(else
(values '() attributes+contents)))))
(for-each (cut write-attribute <> port) attributes)
(display #\> port)
(case rule
((normal)
(for-each (cut write-content #t <> port) contents))
((raw)
(for-each (cut write-content #f <> port) contents))
((void)
(unless (null? contents)
(error
'write-html "void elements cannot have contents"
elt))))
(case rule
((normal raw)
(fprintf port "</~a>" tag)))))))
(write-attribute
(lambda (attr port)
(unless (and (pair? attr) (symbol? (car attr)) (list? (cdr attr)))
(error
'write-html "not a proper attribute"
attr))
(let-values (((key contents) (car+cdr attr)))
(fprintf port " ~a=\"" key)
(for-each (cut write-content #f <> port) contents)
(display #\" port))))
(write-content
(lambda (allow-elements? v port)
(cond
((symbol? v)
(fprintf port "&~a;" v))
((and (integer? v) (positive? v))
(fprintf port "&#~a;" v))
((string? v)
(display (html-escape v) port))
(allow-elements?
(write-element v port))
(else
(error
'write-html "element not allowed in this context"
v))))))
(lambda (html #!optional (port (current-output-port)))
(display "<!DOCTYPE html>" port)
(newline port)
(write-element html port)
(newline port))))
)
;;This page was generated in about 0.011s by Fossil 2.24 [8be0372c10] 2024-04-23 13:25:26

195
src/webgate.scm Normal file
View file

@ -0,0 +1,195 @@
;; -*- mode: Scheme; -*-
;; https://chust.org/repos/chicken-webgate/file?name=webgate.scm&ci=tip
;;
;; 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
srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 srfi-99
data-structures ports extras lolevel irregex tcp posix
suspension tweetnacl)
(module webgate-utils
(compress decompress
write-netstring read-netstring
make-at-reader make-at-read-table use-at-read-table
uri-encode uri-decode
base64-encode base64-decode
write-html)
(import
scheme chicken foreign
srfi-1 srfi-13 srfi-14 srfi-69
(except data-structures compress) extras irregex)
(include
"webgate-utils.scm"))
(module webgate-core
(message make-message message?
message-type message-headers message-body message-text
write-message
max-request-size
request-method-handler
request-body-handler
request-parameter-handler
parameter-list-ref parameter-ref
resource-context current-resource-context resource-context?
resource-context-getenv resource-context-method resource-context-path
response make-response response?
collect-response make-html-response make-error-response
make-redirect-response
response-status response-status-message
write-response
resource-handler resource-uri
(define-resource resource-handler extend-procedure procedure-data)
handle-query-parameters
handle-request)
(import
scheme chicken
srfi-1 srfi-4 srfi-13 srfi-18 srfi-69 srfi-99
data-structures ports extras lolevel irregex
suspension webgate-utils)
(include
"webgate-core.scm"))
(module webgate-suspend
(current-suspension-key
suspended
send/suspend)
(import
scheme chicken
srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
data-structures extras suspension tweetnacl webgate-utils webgate-core
(only posix current-user-id current-group-id current-directory))
(include
"webgate-suspend.scm"))
(module webgate-cgi
(cgi-main-loop)
(import
scheme chicken
(only webgate-core write-response))
(include
"webgate-cgi.scm"))
(module webgate-scgi
(scgi-main-loop)
(import
scheme chicken
srfi-13 srfi-18 srfi-69
data-structures irregex webgate-utils tcp
(only webgate-core write-response))
(include
"webgate-scgi.scm"))
(cond-expand
(enable-webgate-soup
(module webgate-soup
(soup-main-loop)
(import
scheme chicken foreign
srfi-1 srfi-13
data-structures webgate-core)
(include
"webgate-soup.scm")))
(else))
(module webgate
(webgate-main)
(import
scheme chicken
srfi-13 irregex webgate-cgi webgate-scgi tcp
(only webgate-core
handle-request)
(only webgate-suspend
current-suspension-key))
(cond-expand
(enable-webgate-soup
(import webgate-soup))
(else))
(reexport
(only webgate-core
message make-message message?
message-type message-headers message-body message-text
parameter-list-ref parameter-ref
resource-context current-resource-context resource-context?
resource-context-getenv resource-context-method resource-context-path
response make-response response?
collect-response make-html-response make-error-response
make-redirect-response
response-status response-status-message
define-resource resource-uri)
(only webgate-suspend
send/suspend))
(define (webgate-main #!optional (arguments (command-line-arguments)))
(apply
(lambda (#!key (listen #f) (backlog 4) (suspension-key #f))
(cond
(suspension-key => current-suspension-key))
(if listen
(let ((m (irregex-match
'(: (? ($ (+ (~ (":!")))) (":!")) (? ($ (+ (~ (":!")))) (":!")) ($ (+ num)))
listen)))
(if m
(let* ((port
(string->number (irregex-match-substring m 3)))
(host
(cond
((irregex-match-substring m 2)
=> (lambda (host) (if (string=? host "*") #f host)))
(else
"localhost")))
(protocol
(cond
((irregex-match-substring m 1)
=> string->symbol)
(else
'scgi))))
(case protocol
((scgi)
(let ((ear (tcp-listen port backlog host)))
(dynamic-wind
void
(cut scgi-main-loop handle-request ear)
(cut tcp-close ear))))
((http)
(cond-expand
(enable-webgate-soup
(soup-main-loop handle-request port host))
(else
(error 'webgate-main "HTTP support not enabled"))))
(else
(error 'webgate-main "Unknown protocol" protocol))))
(error 'webgate-main "Bad listener specification" listen)))
(cgi-main-loop handle-request)))
(map
(lambda (arg)
(if (string-prefix? "-" arg)
(string->keyword (substring/shared arg 1))
arg))
arguments)))
)
;;This page was generated in about 0.012s by Fossil 2.24 [8be0372c10] 2024-04-23 13:25:26