From ee4de955ded1736f9f4ba8fe2cd21c0c99da2e94 Mon Sep 17 00:00:00 2001 From: TMA Date: Fri, 13 Mar 2026 22:12:20 +0100 Subject: [PATCH] 2025 version --- .gitignore | 6 + Makefile | 52 ++++ install-eggs.sh | 71 ++++++ src/Makefile | 95 ++++++++ src/at-expr-on.scm | 2 + src/brmelect.scm | 113 +++++++++ src/example.scm | 328 +++++++++++++++++++++++++ src/suspension.scm | 97 ++++++++ src/volitelni.awk | 36 +++ src/volitelni.txt | 10 + src/webgate-core.scm | 552 ++++++++++++++++++++++++++++++++++++++++++ src/webgate-utils.scm | 468 +++++++++++++++++++++++++++++++++++ src/webgate.scm | 195 +++++++++++++++ 13 files changed, 2025 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 install-eggs.sh create mode 100644 src/Makefile create mode 100644 src/at-expr-on.scm create mode 100644 src/brmelect.scm create mode 100644 src/example.scm create mode 100644 src/suspension.scm create mode 100644 src/volitelni.awk create mode 100644 src/volitelni.txt create mode 100644 src/webgate-core.scm create mode 100644 src/webgate-utils.scm create mode 100644 src/webgate.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..78ca35a --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*~ +.*.sw? +*.o +*.link +/eggs/ +*.import.scm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..92bea84 --- /dev/null +++ b/Makefile @@ -0,0 +1,52 @@ +# +# Makefile +# +# Wrapper for src/ +# +# ISC License +# +# Copyright 2023 Brmlab, z.s. +# Dominik Pantůček +# +# 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 diff --git a/install-eggs.sh b/install-eggs.sh new file mode 100644 index 0000000..4a7740b --- /dev/null +++ b/install-eggs.sh @@ -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 +# 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 diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..af0d548 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,95 @@ +# +# Makefile +# +# Building the project. +# +# ISC License +# +# Copyright 2023 Brmlab, z.s. +# Dominik Pantůček +# 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) diff --git a/src/at-expr-on.scm b/src/at-expr-on.scm new file mode 100644 index 0000000..86dd51d --- /dev/null +++ b/src/at-expr-on.scm @@ -0,0 +1,2 @@ +(import (only webgate-utils use-at-read-table)) +(use-at-read-table #:list-arguments? #t) diff --git a/src/brmelect.scm b/src/brmelect.scm new file mode 100644 index 0000000..4296494 --- /dev/null +++ b/src/brmelect.scm @@ -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) diff --git a/src/example.scm b/src/example.scm new file mode 100644 index 0000000..51f0d47 --- /dev/null +++ b/src/example.scm @@ -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") "")))) + (tr (td "PATH_INFO") + (td (code ,(or (getenv "PATH_INFO") "")))) + (tr (td "REQUEST_METHOD") + (td (code ,(or (getenv "REQUEST_METHOD") "")))) + (tr (td "REMOTE_ADDR") + (td (code ,(or (getenv "REMOTE_ADDR") "")))) + (tr (td "REMOTE_PORT") + (td (code ,(or (getenv "REMOTE_PORT") "")))))) + } + } + } + @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 diff --git a/src/suspension.scm b/src/suspension.scm new file mode 100644 index 0000000..515b179 --- /dev/null +++ b/src/suspension.scm @@ -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 diff --git a/src/volitelni.awk b/src/volitelni.awk new file mode 100644 index 0000000..58fc6ce --- /dev/null +++ b/src/volitelni.awk @@ -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 ";"; +} + diff --git a/src/volitelni.txt b/src/volitelni.txt new file mode 100644 index 0000000..710b119 --- /dev/null +++ b/src/volitelni.txt @@ -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 + diff --git a/src/webgate-core.scm b/src/webgate-core.scm new file mode 100644 index 0000000..07cd854 --- /dev/null +++ b/src/webgate-core.scm @@ -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 '())))))) + + +) diff --git a/src/webgate-utils.scm b/src/webgate-utils.scm new file mode 100644 index 0000000..6960989 --- /dev/null +++ b/src/webgate-utils.scm @@ -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 ") + +#;(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) + ((#\") """) + ((#\&) "&") + ((#\<) "<") + ((#\>) ">")))))) + (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 "" 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 "" 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 diff --git a/src/webgate.scm b/src/webgate.scm new file mode 100644 index 0000000..cf22f53 --- /dev/null +++ b/src/webgate.scm @@ -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