CGI library fixes
This commit is contained in:
parent
936e34a373
commit
a69cafbcf6
2
Makefile
2
Makefile
|
|
@ -1,7 +1,7 @@
|
|||
.SILENT: build install test test-docker clean ${TMPDIR}
|
||||
SCHEME=chibi
|
||||
LIBRARY=cgi
|
||||
AUTHOR=Retropikzel
|
||||
AUTHOR=retropikzel
|
||||
|
||||
LIBRARY_FILE=retropikzel/${LIBRARY}.sld
|
||||
VERSION=$(shell cat retropikzel/${LIBRARY}/VERSION)
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@
|
|||
(define breaker (char->integer #\-))
|
||||
|
||||
|
||||
(define request
|
||||
#;(define request
|
||||
(list (cons 'headers headers)
|
||||
(cons 'parameters parameters)
|
||||
(cons 'cookies cookies)
|
||||
|
|
@ -222,8 +222,6 @@
|
|||
(close-port input)
|
||||
(close-port output)))
|
||||
|
||||
(define (cgi) request)
|
||||
|
||||
(define cgi-exit
|
||||
(lambda args
|
||||
(for-each (lambda (file)
|
||||
|
|
@ -235,82 +233,89 @@
|
|||
(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)))))
|
||||
(define (cgi)
|
||||
(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)))))
|
||||
|
||||
(list (cons 'headers headers)
|
||||
(cons 'parameters parameters)
|
||||
(cons 'cookies cookies)
|
||||
(cons 'body body)
|
||||
(cons 'files files)))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,165 @@
|
|||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
Version 3, 29 June 2007
|
||||
|
||||
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
|
||||
This version of the GNU Lesser General Public License incorporates
|
||||
the terms and conditions of version 3 of the GNU General Public
|
||||
License, supplemented by the additional permissions listed below.
|
||||
|
||||
0. Additional Definitions.
|
||||
|
||||
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||
General Public License.
|
||||
|
||||
"The Library" refers to a covered work governed by this License,
|
||||
other than an Application or a Combined Work as defined below.
|
||||
|
||||
An "Application" is any work that makes use of an interface provided
|
||||
by the Library, but which is not otherwise based on the Library.
|
||||
Defining a subclass of a class defined by the Library is deemed a mode
|
||||
of using an interface provided by the Library.
|
||||
|
||||
A "Combined Work" is a work produced by combining or linking an
|
||||
Application with the Library. The particular version of the Library
|
||||
with which the Combined Work was made is also called the "Linked
|
||||
Version".
|
||||
|
||||
The "Minimal Corresponding Source" for a Combined Work means the
|
||||
Corresponding Source for the Combined Work, excluding any source code
|
||||
for portions of the Combined Work that, considered in isolation, are
|
||||
based on the Application, and not on the Linked Version.
|
||||
|
||||
The "Corresponding Application Code" for a Combined Work means the
|
||||
object code and/or source code for the Application, including any data
|
||||
and utility programs needed for reproducing the Combined Work from the
|
||||
Application, but excluding the System Libraries of the Combined Work.
|
||||
|
||||
1. Exception to Section 3 of the GNU GPL.
|
||||
|
||||
You may convey a covered work under sections 3 and 4 of this License
|
||||
without being bound by section 3 of the GNU GPL.
|
||||
|
||||
2. Conveying Modified Versions.
|
||||
|
||||
If you modify a copy of the Library, and, in your modifications, a
|
||||
facility refers to a function or data to be supplied by an Application
|
||||
that uses the facility (other than as an argument passed when the
|
||||
facility is invoked), then you may convey a copy of the modified
|
||||
version:
|
||||
|
||||
a) under this License, provided that you make a good faith effort to
|
||||
ensure that, in the event an Application does not supply the
|
||||
function or data, the facility still operates, and performs
|
||||
whatever part of its purpose remains meaningful, or
|
||||
|
||||
b) under the GNU GPL, with none of the additional permissions of
|
||||
this License applicable to that copy.
|
||||
|
||||
3. Object Code Incorporating Material from Library Header Files.
|
||||
|
||||
The object code form of an Application may incorporate material from
|
||||
a header file that is part of the Library. You may convey such object
|
||||
code under terms of your choice, provided that, if the incorporated
|
||||
material is not limited to numerical parameters, data structure
|
||||
layouts and accessors, or small macros, inline functions and templates
|
||||
(ten or fewer lines in length), you do both of the following:
|
||||
|
||||
a) Give prominent notice with each copy of the object code that the
|
||||
Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
4. Combined Works.
|
||||
|
||||
You may convey a Combined Work under terms of your choice that,
|
||||
taken together, effectively do not restrict modification of the
|
||||
portions of the Library contained in the Combined Work and reverse
|
||||
engineering for debugging such modifications, if you also do each of
|
||||
the following:
|
||||
|
||||
a) Give prominent notice with each copy of the Combined Work that
|
||||
the Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
c) For a Combined Work that displays copyright notices during
|
||||
execution, include the copyright notice for the Library among
|
||||
these notices, as well as a reference directing the user to the
|
||||
copies of the GNU GPL and this license document.
|
||||
|
||||
d) Do one of the following:
|
||||
|
||||
0) Convey the Minimal Corresponding Source under the terms of this
|
||||
License, and the Corresponding Application Code in a form
|
||||
suitable for, and under terms that permit, the user to
|
||||
recombine or relink the Application with a modified version of
|
||||
the Linked Version to produce a modified Combined Work, in the
|
||||
manner specified by section 6 of the GNU GPL for conveying
|
||||
Corresponding Source.
|
||||
|
||||
1) Use a suitable shared library mechanism for linking with the
|
||||
Library. A suitable mechanism is one that (a) uses at run time
|
||||
a copy of the Library already present on the user's computer
|
||||
system, and (b) will operate properly with a modified version
|
||||
of the Library that is interface-compatible with the Linked
|
||||
Version.
|
||||
|
||||
e) Provide Installation Information, but only if you would otherwise
|
||||
be required to provide such information under section 6 of the
|
||||
GNU GPL, and only to the extent that such information is
|
||||
necessary to install and execute a modified version of the
|
||||
Combined Work produced by recombining or relinking the
|
||||
Application with a modified version of the Linked Version. (If
|
||||
you use option 4d0, the Installation Information must accompany
|
||||
the Minimal Corresponding Source and Corresponding Application
|
||||
Code. If you use option 4d1, you must provide the Installation
|
||||
Information in the manner specified by section 6 of the GNU GPL
|
||||
for conveying Corresponding Source.)
|
||||
|
||||
5. Combined Libraries.
|
||||
|
||||
You may place library facilities that are a work based on the
|
||||
Library side by side in a single library together with other library
|
||||
facilities that are not Applications and are not covered by this
|
||||
License, and convey such a combined library under terms of your
|
||||
choice, if you do both of the following:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work based
|
||||
on the Library, uncombined with any other library facilities,
|
||||
conveyed under the terms of this License.
|
||||
|
||||
b) Give prominent notice with the combined library that part of it
|
||||
is a work based on the Library, and explaining where to find the
|
||||
accompanying uncombined form of the same work.
|
||||
|
||||
6. Revised Versions of the GNU Lesser General Public License.
|
||||
|
||||
The Free Software Foundation may publish revised and/or new versions
|
||||
of the GNU Lesser General Public License from time to time. Such new
|
||||
versions will be similar in spirit to the present version, but may
|
||||
differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the
|
||||
Library as you received it specifies that a certain numbered version
|
||||
of the GNU Lesser General Public License "or any later version"
|
||||
applies to it, you have the option of following the terms and
|
||||
conditions either of that published version or of any later version
|
||||
published by the Free Software Foundation. If the Library as you
|
||||
received it does not specify a version number of the GNU Lesser
|
||||
General Public License, you may choose any version of the GNU Lesser
|
||||
General Public License ever published by the Free Software Foundation.
|
||||
|
||||
If the Library as you received it specifies that a proxy can decide
|
||||
whether future versions of the GNU Lesser General Public License shall
|
||||
apply, that proxy's public statement of acceptance of any version is
|
||||
permanent authorization for you to choose that version for the
|
||||
Library.
|
||||
|
|
@ -0,0 +1,137 @@
|
|||
<pre>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 "
|
||||
")
|
||||
(display "
|
||||
")
|
||||
(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.</pre>
|
||||
Loading…
Reference in New Issue