Add url-encodng library. Start http-server library
This commit is contained in:
parent
8935852c40
commit
58a24fffa8
5
Makefile
5
Makefile
|
|
@ -39,12 +39,13 @@ init-venv: build
|
||||||
@rm -rf venv
|
@rm -rf venv
|
||||||
@scheme-venv ${SCHEME} ${RNRS} venv
|
@scheme-venv ${SCHEME} ${RNRS} venv
|
||||||
@echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > venv/test.scm
|
@echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > venv/test.scm
|
||||||
@printf "#!r6rs\n(import (rnrs) (srfi :64) (retropikzel ${LIBRARY}))" > venv/test.sps
|
@printf "#!r6rs\n(import (rnrs) (srfi :64) (srfi :98) (retropikzel ${LIBRARY}))" > venv/test.sps
|
||||||
@cat ${TESTFILE} >> venv/test.scm
|
@cat ${TESTFILE} >> venv/test.scm
|
||||||
@cat ${TESTFILE} >> venv/test.sps
|
@cat ${TESTFILE} >> venv/test.sps
|
||||||
@if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
|
@if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
|
||||||
|
@if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c-srfis ]; then cp -r ../foreign-c-srfis/srfi venv/lib/; fi; fi
|
||||||
@if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
|
@if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
|
||||||
@if [ "${SCHEME}" = "chezs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
@if [ "${SCHEME}" = "chezscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||||
@if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
@if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||||
@if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
@if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||||
@if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
@if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,88 @@
|
||||||
|
(define buffer-size 4000)
|
||||||
|
(define response-line-end (string->utf8 "\r\n"))
|
||||||
|
(define response-200 (string->utf8 "HTTP/1.1 200 OK\r\n"))
|
||||||
|
(define response-404 (string->utf8 "HTTP/1.1 404 Not Found\r\n"))
|
||||||
|
(define response-501 (string->utf8 "HTTP/1.1 501 Not Implemented\r\n"))
|
||||||
|
(define header-content-type-text-html (string->utf8 "Content-type: text/html\r\n"))
|
||||||
|
(define (header-content-length len)
|
||||||
|
(string->utf8 (string-append "Content-length: " (number->string len) "\r\n")))
|
||||||
|
|
||||||
|
(define (logger msg) (display msg (current-error-port)))
|
||||||
|
|
||||||
|
(define (receive-all socket bytes result)
|
||||||
|
(if (< (bytevector-length bytes) buffer-size)
|
||||||
|
(bytevector-append result bytes)
|
||||||
|
(receive-all socket
|
||||||
|
(socket-recv socket buffer-size)
|
||||||
|
(bytevector-append result bytes))))
|
||||||
|
|
||||||
|
(define (read-until port character)
|
||||||
|
(letrec ((looper (lambda (result)
|
||||||
|
(let ((c (read-char port)))
|
||||||
|
(if (char=? c character)
|
||||||
|
(list->string (reverse result))
|
||||||
|
(looper (cons c result)))))))
|
||||||
|
(looper (list))))
|
||||||
|
|
||||||
|
(define (read-until-eof port)
|
||||||
|
(letrec ((looper (lambda (result)
|
||||||
|
(let ((bytes (read-bytevector buffer-size)))
|
||||||
|
(if (eof-object? bytes)
|
||||||
|
result
|
||||||
|
(looper (bytevector-append result bytes)))))))
|
||||||
|
(looper (bytevector))))
|
||||||
|
|
||||||
|
(define (send socket bytes)
|
||||||
|
;(display "Sending: ")
|
||||||
|
;(write (utf8->string bytes))
|
||||||
|
;(newline)
|
||||||
|
(socket-send socket bytes))
|
||||||
|
|
||||||
|
(define (http-server-listen server-socket document-root port)
|
||||||
|
(call-with-socket
|
||||||
|
(socket-accept server-socket)
|
||||||
|
(lambda (client-socket)
|
||||||
|
(let ((request-type (utf8->string (socket-recv client-socket 4))))
|
||||||
|
(cond
|
||||||
|
((string=? request-type "GET ")
|
||||||
|
(logger "GET: ")
|
||||||
|
(let* ((request
|
||||||
|
(utf8->string
|
||||||
|
(receive-all client-socket
|
||||||
|
(socket-recv client-socket buffer-size)
|
||||||
|
(bytevector))))
|
||||||
|
(request-port (open-input-string request))
|
||||||
|
(request-path (url-decode (read-until request-port #\space)))
|
||||||
|
(request-full-path (string-append document-root request-path)))
|
||||||
|
(logger request-path)
|
||||||
|
(cond
|
||||||
|
((file-exists? request-full-path)
|
||||||
|
(let ((contents
|
||||||
|
(with-input-from-file
|
||||||
|
request-full-path
|
||||||
|
(lambda ()
|
||||||
|
(read-until-eof (current-input-port))))))
|
||||||
|
(send client-socket response-200)
|
||||||
|
(send client-socket header-content-type-text-html)
|
||||||
|
(send client-socket
|
||||||
|
(header-content-length
|
||||||
|
(bytevector-length contents)))
|
||||||
|
(send client-socket response-line-end)
|
||||||
|
(send client-socket contents)
|
||||||
|
(send client-socket response-line-end)
|
||||||
|
(logger " -> 200 OK")
|
||||||
|
(logger #\newline)))
|
||||||
|
(else (send client-socket response-404)
|
||||||
|
(send client-socket response-line-end)
|
||||||
|
(logger " -> 404 Not found")
|
||||||
|
(logger #\newline)))))
|
||||||
|
(else (send client-socket response-501))))
|
||||||
|
(socket-close client-socket)
|
||||||
|
(http-server-listen server-socket document-root port))))
|
||||||
|
|
||||||
|
(define (http-server document-root port)
|
||||||
|
(let ((server-socket
|
||||||
|
(make-server-socket (if (number? port) (number->string port) port))))
|
||||||
|
(when (char=? (car (reverse (string->list document-root))) #\/)
|
||||||
|
(error "document-root can not end with /" document-root))
|
||||||
|
(http-server-listen server-socket document-root port)))
|
||||||
|
|
@ -0,0 +1,11 @@
|
||||||
|
(define-library
|
||||||
|
(retropikzel http-server)
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme read)
|
||||||
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
|
(scheme file)
|
||||||
|
(retropikzel url-encoding)
|
||||||
|
(srfi 106))
|
||||||
|
(export http-server)
|
||||||
|
(include "http-server.scm"))
|
||||||
|
|
@ -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 @@
|
||||||
|
Simple HTTP server library for serving files on localhost
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
0.1.0
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
(define document-root (string-append (get-environment-variable "PWD") "/retropikzel/http-server/www"))
|
||||||
|
(http-server document-root "3005")
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
<html>
|
||||||
|
<head>
|
||||||
|
</head>
|
||||||
|
<body>
|
||||||
|
Hello
|
||||||
|
</body>
|
||||||
|
</html>
|
||||||
|
|
@ -0,0 +1,253 @@
|
||||||
|
(define chunk-size 4000)
|
||||||
|
(define slash-r (bytevector-u8-ref (string->utf8 "\r") 0))
|
||||||
|
(define slash-n (bytevector-u8-ref (string->utf8 "\n") 0))
|
||||||
|
|
||||||
|
(define remove-leading-whitespate
|
||||||
|
(lambda (str)
|
||||||
|
(if (or (= (string-length str) 0)
|
||||||
|
(not (char-whitespace? (string-ref str 0))))
|
||||||
|
str
|
||||||
|
(remove-leading-whitespate (string-copy str )))))
|
||||||
|
|
||||||
|
(define http-util-header-line->pair
|
||||||
|
(lambda (line)
|
||||||
|
(letrec* ((split
|
||||||
|
(lambda (first rest)
|
||||||
|
(if (or (= (string-length rest) 0)
|
||||||
|
(char=? #\: (string-ref rest 0)))
|
||||||
|
(cons (string->symbol (string-downcase first)) (remove-leading-whitespate (string-copy rest 2)))
|
||||||
|
(split (string-append first (string (string-ref rest 0)))
|
||||||
|
(string-copy rest 1))))))
|
||||||
|
(split "" line))))
|
||||||
|
|
||||||
|
(define http-util-status-line->list
|
||||||
|
(lambda (line)
|
||||||
|
(letrec* ((split
|
||||||
|
(lambda (first second rest space-count)
|
||||||
|
(cond ((char=? #\space (string-ref rest 0))
|
||||||
|
(split first second (string-copy rest 1) (+ space-count 1)))
|
||||||
|
((= space-count 0)
|
||||||
|
(split (string-append first (string-copy rest 0 1))
|
||||||
|
second
|
||||||
|
(string-copy rest 1)
|
||||||
|
space-count))
|
||||||
|
((= space-count 1)
|
||||||
|
(split first
|
||||||
|
(string-append second (string-copy rest 0 1))
|
||||||
|
(string-copy rest 1)
|
||||||
|
space-count))
|
||||||
|
((= space-count 2)
|
||||||
|
(list first (if (number? second)
|
||||||
|
(string->number second)
|
||||||
|
second)
|
||||||
|
rest))))))
|
||||||
|
(split "" "" line 0))))
|
||||||
|
|
||||||
|
(define read-lines-until-empty
|
||||||
|
(lambda (port result)
|
||||||
|
(let ((line (read-line port)))
|
||||||
|
(if (string=? "" line)
|
||||||
|
result
|
||||||
|
(read-lines-until-empty port (append result (list line)))))))
|
||||||
|
|
||||||
|
(define http-util-headers->string
|
||||||
|
(lambda (headers)
|
||||||
|
(apply string-append
|
||||||
|
(map
|
||||||
|
(lambda (header)
|
||||||
|
(string-append (symbol->string (car header))
|
||||||
|
": "
|
||||||
|
(cdr header)
|
||||||
|
"\r\n"))
|
||||||
|
headers))))
|
||||||
|
|
||||||
|
(define http-util-request-build
|
||||||
|
(lambda (type path headers body)
|
||||||
|
(string-append (string-upcase type)
|
||||||
|
" "
|
||||||
|
path
|
||||||
|
" "
|
||||||
|
"HTTP/1.1"
|
||||||
|
"\r\n"
|
||||||
|
(http-util-headers->string headers)
|
||||||
|
"\r\n"
|
||||||
|
body
|
||||||
|
"\r\n\r\n")))
|
||||||
|
|
||||||
|
(define receive-all-from-socket
|
||||||
|
(lambda (socket)
|
||||||
|
(letrec ((looper (lambda (result-bytes)
|
||||||
|
(let ((bytes (socket-recv socket 4000)))
|
||||||
|
(if (or (eof-object? bytes)
|
||||||
|
(= (bytevector-length bytes) 0))
|
||||||
|
result-bytes
|
||||||
|
(looper (bytevector-append result-bytes bytes)))))))
|
||||||
|
(looper (bytevector)))))
|
||||||
|
|
||||||
|
(define receive-http-request-from-socket
|
||||||
|
(lambda (socket)
|
||||||
|
(letrec* ((looper (lambda (result-bytes)
|
||||||
|
(let ((bytes (socket-recv socket 8)))
|
||||||
|
(if (or (eof-object? bytes)
|
||||||
|
(= (bytevector-length bytes) 0))
|
||||||
|
result-bytes
|
||||||
|
(begin
|
||||||
|
(display (utf8->string bytes))
|
||||||
|
(newline)
|
||||||
|
(looper (bytevector-append result-bytes bytes))))))))
|
||||||
|
(looper (bytevector)))))
|
||||||
|
|
||||||
|
(define read-chunked-body
|
||||||
|
(lambda (port)
|
||||||
|
(letrec ((looper (lambda (body)
|
||||||
|
(let ((chunk-size (string-append "#x" (read-line port))))
|
||||||
|
(if (= (string->number chunk-size) 0)
|
||||||
|
body
|
||||||
|
(looper (string-append body
|
||||||
|
"\r\n"
|
||||||
|
(read-string (+ (string->number chunk-size) 2) port))))))))
|
||||||
|
(string->utf8 (looper "")))))
|
||||||
|
|
||||||
|
(define http-util-read-http-response
|
||||||
|
(lambda (socket)
|
||||||
|
(let* ((response (receive-all-from-socket socket))
|
||||||
|
(port (open-input-string (utf8->string response)))
|
||||||
|
(status-line (http-util-status-line->list (read-line port)))
|
||||||
|
(headers (map http-util-header-line->pair (read-lines-until-empty port (list))))
|
||||||
|
(body (cond ((assoc 'content-length headers)
|
||||||
|
(read-bytevector (string->number (cdr (assoc 'content-length headers))) port))
|
||||||
|
((and (assoc 'transfer-encoding headers)
|
||||||
|
(string=? (cdr (assoc 'transfer-encoding headers)) "chunked"))
|
||||||
|
(read-chunked-body port))
|
||||||
|
((and (assoc 'connection headers)
|
||||||
|
(string=? (cdr (assoc 'connection headers)) "close"))
|
||||||
|
(letrec ((looper (lambda (result line)
|
||||||
|
(if (eof-object? line)
|
||||||
|
result
|
||||||
|
(looper (bytevector-append result line)
|
||||||
|
(read-bytevector 4000 port))))))
|
||||||
|
(looper (bytevector) (read-bytevector 4000 port))))
|
||||||
|
(else (bytevector)))))
|
||||||
|
(list (cons 'status-line status-line)
|
||||||
|
(cons 'protocol (list-ref status-line 0))
|
||||||
|
(cons 'status-code (string->number (list-ref status-line 1)))
|
||||||
|
(cons 'status-text (list-ref status-line 2))
|
||||||
|
(cons 'headers headers)
|
||||||
|
(cons 'body body)))))
|
||||||
|
|
||||||
|
(define socket-receive-line
|
||||||
|
(lambda (socket)
|
||||||
|
(letrec ((looper (lambda (result-bytes)
|
||||||
|
(let ((byte (socket-recv socket 1)))
|
||||||
|
(cond ((= (bytevector-length byte) 0) result-bytes)
|
||||||
|
((= (bytevector-u8-ref byte 0) slash-r)
|
||||||
|
(let ((next-byte (socket-recv socket 1)))
|
||||||
|
(if (or (= (bytevector-length next-byte) 0)
|
||||||
|
(= (bytevector-u8-ref next-byte 0) slash-n))
|
||||||
|
result-bytes
|
||||||
|
(looper (bytevector-append result-bytes byte next-byte)))))
|
||||||
|
(else (looper (bytevector-append result-bytes byte))))))))
|
||||||
|
(looper (bytevector)))))
|
||||||
|
|
||||||
|
(define socket-receive-headers
|
||||||
|
(lambda (socket)
|
||||||
|
(letrec ((looper (lambda (result)
|
||||||
|
(let ((line (utf8->string (socket-receive-line socket))))
|
||||||
|
(if (string=? line "")
|
||||||
|
result
|
||||||
|
(looper (append result (list line))))))))
|
||||||
|
(map http-util-header-line->pair (looper (list))))))
|
||||||
|
|
||||||
|
(define http-util-read-http-request
|
||||||
|
(lambda (socket)
|
||||||
|
(let* ((status-line (http-util-status-line->list (utf8->string (socket-receive-line socket))))
|
||||||
|
(headers (socket-receive-headers socket))
|
||||||
|
(body (let ((content-length (assoc 'content-length headers)))
|
||||||
|
(if content-length
|
||||||
|
(socket-recv socket (string->number (cdr content-length)))
|
||||||
|
""))))
|
||||||
|
(list (cons 'status-line status-line)
|
||||||
|
(cons 'headers headers)
|
||||||
|
(list 'body body)))))
|
||||||
|
|
||||||
|
(define http-util-download-file
|
||||||
|
(lambda (url path port headers output-file-path)
|
||||||
|
(let* ((headers-with-host (append headers
|
||||||
|
(list
|
||||||
|
(cons 'host
|
||||||
|
(string-append url ":" (number->string port))))))
|
||||||
|
(request (http-util-request-build "GET" path headers-with-host ""))
|
||||||
|
(socket (make-client-socket url (number->string port))))
|
||||||
|
(socket-send socket (string->utf8 request))
|
||||||
|
(let* ((socket-port (socket-input-port socket))
|
||||||
|
(status-line (http-util-status-line->list (read-line socket-port)))
|
||||||
|
(headers (map http-util-header-line->pair (read-lines-until-empty socket-port (list))))
|
||||||
|
(content-length (if (assoc 'content-length headers)
|
||||||
|
(string->number (cdr (assoc 'content-length headers)))
|
||||||
|
chunk-size))
|
||||||
|
(status-code (string->number (list-ref status-line 1))))
|
||||||
|
(if (not (= status-code 200))
|
||||||
|
(error (string-append "Could not download file from " url "/" path) headers))
|
||||||
|
(letrec* ((output-port (open-binary-output-file output-file-path))
|
||||||
|
(looper
|
||||||
|
(lambda (bytes)
|
||||||
|
(if (not (eof-object? bytes))
|
||||||
|
(begin
|
||||||
|
(write-bytevector bytes output-port)
|
||||||
|
(looper (read-bytevector chunk-size socket-port)))))))
|
||||||
|
(looper (read-bytevector content-length socket-port))
|
||||||
|
(close-port output-port)
|
||||||
|
(close-port socket-port)
|
||||||
|
(socket-close socket))))))
|
||||||
|
|
||||||
|
(define http-util-request-make
|
||||||
|
(lambda (type url path port headers body)
|
||||||
|
(let* ((headers-with-host (append headers
|
||||||
|
(list
|
||||||
|
(cons 'host
|
||||||
|
(string-append url ":" (number->string port))))))
|
||||||
|
(request (http-util-request-build "GET" path headers-with-host body))
|
||||||
|
(socket (make-client-socket url (number->string port))))
|
||||||
|
(socket-send socket (string->utf8 request))
|
||||||
|
(let ((response (http-util-read-http-response socket)))
|
||||||
|
(socket-close socket)
|
||||||
|
response))))
|
||||||
|
|
||||||
|
(define http-util-response-build
|
||||||
|
(lambda (code code-text headers body)
|
||||||
|
(let ((headers-with-content-length (append headers
|
||||||
|
(list (cons 'content-length
|
||||||
|
(number->string (string-length body)))))))
|
||||||
|
|
||||||
|
(string-append "HTTP/1.1"
|
||||||
|
" "
|
||||||
|
(number->string code)
|
||||||
|
" "
|
||||||
|
code-text
|
||||||
|
"\r\n"
|
||||||
|
(http-util-headers->string headers-with-content-length)
|
||||||
|
"\r\n"
|
||||||
|
body))))
|
||||||
|
|
||||||
|
(define http-util-parameters-split
|
||||||
|
(lambda (body)
|
||||||
|
(cond ((and (string? body) (string=? "" body)) (list))
|
||||||
|
((string? body) (let ((bodylist (string->list body)))
|
||||||
|
(map (lambda (x) (string-split x #\=))
|
||||||
|
(string-split (list->string
|
||||||
|
(if (string=? "?" (string (car bodylist)))
|
||||||
|
(cdr bodylist)
|
||||||
|
bodylist)) #\&))))
|
||||||
|
(else (list)))))
|
||||||
|
|
||||||
|
(define http-util-parameter-get
|
||||||
|
(lambda (key params)
|
||||||
|
(let ((value #f))
|
||||||
|
(if (list? params)
|
||||||
|
(map (lambda (x)
|
||||||
|
(if (and (string? (car (cdr x)))
|
||||||
|
(string? (car x))
|
||||||
|
(string=? key (car x)))
|
||||||
|
(set! value (car (cdr x)))))
|
||||||
|
params))
|
||||||
|
value)))
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
(define-library
|
||||||
|
(retropikzel http-util)
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme read)
|
||||||
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
|
(scheme file)
|
||||||
|
(srfi 106))
|
||||||
|
(export http-util-headers->string
|
||||||
|
http-util-header-line->pair
|
||||||
|
http-util-status-line->list
|
||||||
|
http-util-request-build
|
||||||
|
http-util-request-make
|
||||||
|
http-util-response-build
|
||||||
|
http-util-download-file
|
||||||
|
http-util-read-http-request
|
||||||
|
http-util-read-http-response
|
||||||
|
http-util-parameters-split
|
||||||
|
http-util-parameter-get)
|
||||||
|
(include "http-util.scm"))
|
||||||
|
|
@ -0,0 +1,59 @@
|
||||||
|
(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 (get-replacement key mode)
|
||||||
|
(let ((r (if (string=? mode "encode")
|
||||||
|
(assoc key encode-replacements)
|
||||||
|
(assoc key decode-replacements))))
|
||||||
|
(if r (car (cdr r)) key)))
|
||||||
|
|
||||||
|
(define (endecode 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 (url-encode str) (cond ((string? str) (endecode "encode" str)) (else str)))
|
||||||
|
(define (url-decode str) (cond ((string? str) (endecode "decode" str)) (else str)))
|
||||||
|
|
@ -0,0 +1,6 @@
|
||||||
|
(define-library
|
||||||
|
(retropikzel url-encoding)
|
||||||
|
(import (scheme base))
|
||||||
|
(export url-encode
|
||||||
|
url-decode)
|
||||||
|
(include "url-encoding.scm"))
|
||||||
|
|
@ -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 @@
|
||||||
|
URL-encoding and decoding procedures
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
1.0.0
|
||||||
Loading…
Reference in New Issue