Moving libraries
This commit is contained in:
commit
936e34a373
|
|
@ -0,0 +1,7 @@
|
|||
*/README.html
|
||||
*.swp
|
||||
*.swo
|
||||
*.tgz
|
||||
tmp
|
||||
*.log
|
||||
|
||||
|
|
@ -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
|
||||
}
|
||||
}
|
||||
}]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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"))
|
||||
|
|
@ -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.
|
||||
|
|
@ -0,0 +1 @@
|
|||
1.0.1
|
||||
|
|
@ -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")
|
||||
Loading…
Reference in New Issue