Retropikzel
/
scheme-libraries
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Moving libraries

This commit is contained in:
retropikzel 2025-10-29 16:53:08 +02:00
commit 936e34a373
8 changed files with 583 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitignore vendored Normal file
View File

@ -0,0 +1,7 @@
*/README.html
*.swp
*.swo
*.tgz
tmp
*.log

44
Jenkinsfile vendored Normal file
View File

@ -0,0 +1,44 @@
pipeline {
agent {
dockerfile {
label 'docker-x86_64'
filename 'Dockerfile.jenkins'
args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
reuseNode true
}
}
options {
disableConcurrentBuilds()
buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
}
parameters {
string(name: 'LIBRARIES', defaultValue: 'cgi', description: '')
}
stages {
stage('Tests') {
steps {
script {
def implementations = sh(script: 'compile-r7rs --list-r7rs-schemes', returnStdout: true).split()
params.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
parallel implementations.collectEntries { SCHEME ->
[(SCHEME): {
stage("${SCHEME}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "make SCHEME=${SCHEME} clean test-docker"
archiveArtifacts artifacts: 'tmp/*/*.log', fingerprint: true
}
}
}]
}
}
}
}
}
}
}
}

56
Makefile Normal file
View File

@ -0,0 +1,56 @@
.SILENT: build install test test-docker clean ${TMPDIR}
SCHEME=chibi
LIBRARY=cgi
AUTHOR=Retropikzel
LIBRARY_FILE=retropikzel/${LIBRARY}.sld
VERSION=$(shell cat retropikzel/${LIBRARY}/VERSION)
DESCRIPTION=$(shell head -n1 retropikzel/${LIBRARY}/README.md)
README=retropikzel/${LIBRARY}/README.html
TESTFILE=retropikzel/${LIBRARY}/test.scm
PKG=${AUTHOR}-${LIBRARY}-${VERSION}.tgz
TMPDIR=tmp/${SCHEME}
DOCKERIMG=${SCHEME}:head
ifeq "${SCHEME}" "chicken"
DOCKERIMG="chicken:5"
endif
all: build
build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION
echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
install:
snow-chibi install --impls=${SCHEME} ${SNOW_CHIBI_ARGS} ${PKG}
uninstall:
-snow-chibi remove --impls=${SCHEME} ${PKG}
${TMPDIR}:
@mkdir -p ${TMPDIR}
@cp ${TESTFILE} ${TMPDIR}/
@mkdir -p ${TMPDIR}/retropikzel
@cp -r retropikzel/${LIBRARY} ${TMPDIR}/retropikzel/
@cp -r retropikzel/${LIBRARY}.s* ${TMPDIR}/retropikzel/
test: ${TMPDIR}
echo "Hello"
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-r7rs -I . -o test test.scm
cd ${TMPDIR} && ./test
test-docker: ${TMPDIR}
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=scheme-library-test-${SCHEME} -f Dockerfile.test . 2> ${TMPDIR}/docker.log || cat ${TMPDIR}/docker.log
docker run -v "${PWD}:/workdir" -w /workdir -t scheme-library-test-${SCHEME} \
sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes build install test; chmod -R 755 ${TMPDIR}"
clean:
find . -name "README.html" -delete
find . -name "*.log" -delete
rm -rf ${TMPDIR}
rm -rf *.tgz
clean-all:
rm -rf tmp

316
retropikzel/cgi.scm Normal file
View File

@ -0,0 +1,316 @@
(define stdin (open-binary-input-file "/dev/fd/0"))
(define buffer-size 4000)
(define temporary-directory (if (get-environment-variable "SCHEME_CGI_TMP_PATH")
(get-environment-variable "SCHEME_CGI_TMP_PATH")
"/tmp"))
(define file-move-buffer-size 4000)
(define encode-replacements
(list (list " " "%20")
(list " " "+")
(list "!" "%21")
(list "#" "%23")
(list "$" "%24")
(list "%" "%25")
(list "&" "%26")
(list "'" "%27")
(list "(" "%28")
(list ")" "%29")
(list "*" "%2A")
(list "+" "%2B")
(list "," "%2C")
(list "/" "%2F")
(list ":" "%3A")
(list ";" "%3B")
(list "=" "%3D")
(list "?" "%3F")
(list "@" "%40")
(list "[" "%5B")
(list "]" "%5D")
(list "<" "%3C")
(list ">" "%3E")
(list "\\" "%5C")
(list "\"" "%22")
(list "\n" "%0A")
(list "\r" "%0D")))
(define decode-replacements (map reverse encode-replacements))
(define make-temp-filename
(lambda (filename)
(letrec* ((dev-random (open-binary-input-file "/dev/random"))
(min-byte (char->integer #\a))
(max-byte (char->integer #\z))
(max-length 10)
(looper (lambda (result count)
(if (>= count max-length)
result
(let ((byte (read-u8 dev-random)))
(if (and (> byte min-byte) (< byte max-byte))
(looper (bytevector-append result
(bytevector byte))
(+ count 1))
(looper result count))))))
(result (string-append (utf8->string (looper (bytevector) 0))
"_"
(utf8->string (looper (bytevector) 0))
"_"
filename)))
(close-port dev-random)
result)))
#;(define headers->string
(lambda (headers)
(apply string-append (map
(lambda (key-value)
(string-append (car key-value) ": " (cdr key-value) "\r\n"))
headers))))
(define get-replacement
(lambda (key mode)
(let ((r (if (string=? mode "encode")
(assoc key encode-replacements)
(assoc key decode-replacements))))
(if r (car (cdr r)) key))))
(define endecode
(lambda (mode s)
(if (not s)
""
(letrec ((s-length (string-length s))
(looper
(lambda (i result)
(if (< i s-length)
(let ((key-length (if (and (string=? mode "decode")
(string=? (string-copy s i (+ i 1)) "%")
(> s-length (+ i 2)))
3
1)))
(looper (+ i key-length)
(string-append result
(get-replacement
(string-copy s i (+ i key-length))
mode))))
result))))
(looper 0 "")))))
(define string-split
(lambda (str mark)
(let* ((str-l (string->list str))
(res (list))
(last-index 0)
(index 0)
(splitter (lambda (c)
(cond ((char=? c mark)
(begin
(set! res (append res (list (string-copy str last-index index))))
(set! last-index (+ index 1))))
((equal? (length str-l) (+ index 1))
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
(set! index (+ index 1)))))
(for-each splitter str-l)
res)))
(define split-http-parameters
(lambda (body)
(cond ((or (not (string? body))
(string=? "" body))
(list))
(else (let ((bodylist (string->list body)))
(map (lambda (p)
(cons (string->symbol (list-ref p 0))
(if (> (length p) 1)
(list-ref p 1)
"")))
(map (lambda (x) (string-split x #\=))
(string-split (list->string bodylist)
#\&))))))))
(define read-until-eof
(lambda (port result)
(let ((c (read-bytevector buffer-size port)))
(if (eof-object? c)
(utf8->string result)
(read-until-eof port (bytevector-append result c))))))
(define read-binary-port-until
(lambda (port result until)
(let ((byte (read-u8 port)))
(if (or (eof-object? byte)
(= byte until))
result
(read-binary-port-until port (bytevector-append result
(bytevector byte))
until)))))
(define read-bytevector-line
(lambda (port)
(let* ((result (utf8->string (read-binary-port-until port
(bytevector)
(char->integer #\newline))))
(result-length (string-length result))
(ends-in-return? (and (> result-length 0)
(char=? (string-ref result (- result-length 1))
#\return))))
(cond ((= result-length 0) "")
(ends-in-return? (string-copy result 0 (- result-length 1)))
(else result)))))
(define string-filter
(lambda (str filter)
(let ((result (list)))
(string-for-each
(lambda (c)
(if (filter c)
(set! result (append result (list c)))))
str)
(list->string result))))
(define headers (map (lambda (p)
(cons (string->symbol (car p))
(cdr p)))
(get-environment-variables)))
(define content-type-pair (if (assoc 'CONTENT_TYPE headers)
(assoc 'CONTENT_TYPE headers)
(cons "Content-Type" "text/html")))
(define content-type-data (string-split (cdr content-type-pair) #\;))
(define content-type (list-ref content-type-data 0))
(define request-method (if (assoc 'REQUEST_METHOD headers)
(cdr (assoc 'REQUEST_METHOD headers))
"GET"))
(define query-string (if (assoc 'QUERY_STRING headers)
(cdr (assoc 'QUERY_STRING headers))
""))
(define parameters (list))
(define cookies (let ((cookie-string (get-environment-variable "HTTP_COOKIE")))
(if cookie-string
(split-http-parameters cookie-string)
(list))))
(define body "")
(define files (list))
(define breaker (char->integer #\-))
(define request
(list (cons 'headers headers)
(cons 'parameters parameters)
(cons 'cookies cookies)
(cons 'body body)
(cons 'files files)))
(define (get from key)
(let ((value (assoc (if (string? key)
(string->symbol (endecode "encode" key))
key)
from)))
(if value (cdr value) #f)))
(define (get-file file)
(let ((value (assoc (endecode "encode" (if (symbol? file)
(symbol->string file)
file))
files)))
(if value (cdr value) #f)))
(define (move-file from to)
(letrec* ((input (open-binary-input-file from))
(output (open-binary-output-file to))
(looper (lambda (bytes)
(when (not (eof-object? bytes))
(write-bytevector bytes output)
(looper (read-bytevector file-move-buffer-size input))))))
(looper (read-bytevector file-move-buffer-size input))
(close-port input)
(close-port output)))
(define (cgi) request)
(define cgi-exit
(lambda args
(for-each (lambda (file)
(let ((path (cdr file)))
(when (file-exists? path)
(delete-file path))))
files)
(if (null? args)
(exit 0)
(exit (car args)))))
(cond ((and content-type-pair (string=? content-type "multipart/form-data"))
(letrec* ((boundary (string->utf8 (string-append (list-ref (string-split
(list-ref content-type-data 1) #\=) 1))))
(boundary-length (bytevector-length boundary))
(content (letrec ((looper (lambda (bytes result)
(if (eof-object? bytes)
result
(looper (read-bytevector buffer-size stdin)
(bytevector-append result bytes))))))
(looper (read-bytevector buffer-size stdin)
(bytevector))))
(header-content-length (string->number (cdr (assoc 'CONTENT_LENGTH headers))))
(content-length (bytevector-length content))
(content-mark 0)
(looper (lambda (index)
(cond ((< index (- content-length 4))
(if (and (= breaker (bytevector-u8-ref content index))
(= breaker (bytevector-u8-ref content (+ index 1)))
(equal? boundary (bytevector-copy content (+ index 2) (+ index 2 boundary-length))))
(let* ((part (bytevector-copy content content-mark index))
(part-length (bytevector-length part))
(part-port (open-input-bytevector part))
(part-headers-length 0)
(part-headers (letrec ((loop (lambda (line result)
(if (or (eof-object? line) (string=? line ""))
(map (lambda (p) (string-split p #\:)) result)
(begin
(set! part-headers-length (+ part-headers-length
(string-length line)
2))
(loop (read-bytevector-line part-port)
(append result (list line))))))))
(loop (read-bytevector-line part-port) (list)))))
(if (and (not (null? part-headers))
(assoc "Content-Disposition" part-headers))
(let* ((content-disposition
(map
(lambda (str)
(let ((split (string-split str #\=)))
(cons (string-filter (list-ref split 0) (lambda (c) (not (char=? c #\space))))
(if (= (length split) 2)
(string-filter (list-ref split 1) (lambda (c) (not (char=? c #\"))))
""))))
(string-split (car (cdr (assoc "Content-Disposition" part-headers))) #\;)))
(filename (assoc "filename" content-disposition)))
(if (not filename)
(set! parameters
(append parameters
(list
(cons (cdr (assoc "name" content-disposition))
(utf8->string (bytevector-copy content
(+ (+ content-mark part-headers-length) 2)
(- index 2)))))))
(let* ((tmp-file-path (string-append temporary-directory
"/"
(make-temp-filename (cdr filename))))
(tmp-file-port (begin (when (file-exists? tmp-file-path)
(delete-file tmp-file-path))
(open-binary-output-file tmp-file-path))))
(write-bytevector (bytevector-copy content
(+ (+ content-mark part-headers-length) 2)
(- index 2))
tmp-file-port)
(close-port tmp-file-port)
(set! files (append files (list
(cons (cdr (assoc "name" content-disposition))
tmp-file-path))))))
(set! content-mark index)))
(looper (+ index boundary-length)))
(looper (+ index 1))))))))
(looper 0)))
(else (let ((raw-body (if (string=? request-method "POST")
(read-until-eof stdin (bytevector))
"")))
(set! parameters (split-http-parameters (if (string=? request-method "POST")
raw-body
query-string)))
(when (string=? request-method "POST")
(set! body raw-body)))))

12
retropikzel/cgi.sld Normal file
View File

@ -0,0 +1,12 @@
(define-library
(retropikzel cgi)
(import (scheme base)
(scheme time)
(scheme read)
(scheme write)
(scheme file)
(scheme char)
(scheme process-context))
(export cgi
cgi-exit)
(include "cgi.scm"))

135
retropikzel/cgi/README.md Normal file
View File

@ -0,0 +1,135 @@
R7RS Scheme library for Common Gateway Interface
If you dont know what CGI is, in short server runs your Scheme script and
displays it's output as a webpage. Also checkout
[https://git.sr.ht/~retropikzel/scheme-php](https://git.sr.ht/~retropikzel/scheme-php).
[Project](https://sr.ht/~retropikzel/scheme-cgi/)
[Repository](https://git.sr.ht/~retropikzel/scheme-cgi)
[Issue tracker](https://todo.sr.ht/~retropikzel/scheme-cgi)
## Caveats
- Works only on unix as it reads from /dev/fd/0 and /dev/random.
## Buggy on implementations
- Does not work with mit-scheme
- For some reason mit-scheme exits when it reads eof-object from standard
input
- STklos
- No output for some reason
## How to use
Example using Gauche in Docker.
lighttpd.conf:
server.document-root = "/workdir"
server.port = 3000
server.modules += ("mod_cgi", "mod_dirlisting")
cgi.assign = (".scm" => "/usr/bin/scheme-script")
dir-listing.activate = "enable"
Dockerfile:
FROM schemers/gauche
RUN apt-get update && apt-get install -y --no-install-recommends lighttpd
WORKDIR /workdir
EXPOSE 3000
COPY lighttpd.conf /lighttpd.conf
RUN echo "#!/bin/sh" > /usr/bin/scheme-script
RUN echo "exec gosh -r7 -I ./snow \$@" >> /usr/bin/scheme-script
RUN chmod +x /usr/bin/scheme-script
ENTRYPOINT ["/usr/sbin/lighttpd", "-D", "-f", "/lighttpd.conf"]
hello.scm:
(import (scheme base)
(scheme write)
(retropikzel cgi))
(display "Content-type: text/html")
(display "\r\n")
(display "\r\n")
(display "Hello")
(display "</br>")
(display "Request: ")
(write (get-request))
(display "</br>")
(cgi-exit)
Run:
docker build . --tag=scheme-cgi
docker run -it -v ${PWD}:/workdir -p 3000:3000 scheme-cgi
Then navigate with your browser to http://127.0.0.1:3000
## Documentation
### Reference
**get-request**
Returns the whole request as association list.
**get-header** _name_
Name can be symbol or a string. Returns the value of given header or #f.
**get-headers**
Returns association list of all headers.
**get-parameter** _name_
Name can be symbol or a string. Returns the value of given parameter or #f.
**get-parameters**
Returns association list of all parameters.
**get-cookie** _name_
Returns the value of given cookie or #f if.
**get-cookies**
Returns association list of all cookies.
**get-file** _filename_
Filename is a symbol or a string. Returns the path of given file from files or #f.
Uploaded files are stored in /tmp, with randomly generated prefix on their
name. They are not deleted unless cgi-exit is called. Use **move-file** to move
them into preferred location.
**get-files**
Returns association list of all files.
**move-file** _from_ _to_
Moves a file from _from_ path to _to_ path.
**get-body**
Returns the request body.
**cgi-exit**</br>
**cgi-exit** _code_
Does necessary cleanup and exits the script. Code is a number, if it is given
then that is used as exit code.
### Environment variables
**SCHEME\_CGI\_TMP\_PATH**
Path to where uploaded files are stored. Default is /tmp.

1
retropikzel/cgi/VERSION Normal file
View File

@ -0,0 +1 @@
1.0.1

12
retropikzel/cgi/test.scm Normal file
View File

@ -0,0 +1,12 @@
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel cgi)
(srfi 64))
(test-begin "cgi")
(display "Hello")
(test-end "cgi")