818 lines
19 KiB
Scheme
818 lines
19 KiB
Scheme
;; Scheme 48 package definitions for the
|
|
;; Scheme Untergrund Networking Suite
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
|
|
;;; Copyright (c) 1996-2002 by Mike Sperber.
|
|
;;; Copyright (c) 2000-2002 by Martin Gasbichler.
|
|
;;; Copyright (c) 1998-2001 by Eric Marsden.
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
;; Interfaces
|
|
|
|
;; Net protocols and formats
|
|
|
|
(define-interface parse-html-forms-interface
|
|
(export parse-html-form-query unescape-uri+))
|
|
|
|
(define-interface htmlout-interface
|
|
(export emit-tag
|
|
emit-close-tag
|
|
|
|
emit-p
|
|
emit-title
|
|
emit-header ; And so forth...
|
|
|
|
with-tag
|
|
with-tag*
|
|
|
|
escape-html
|
|
emit-text))
|
|
|
|
(define-interface smtp-interface
|
|
(export smtp-send-mail
|
|
smtp-expand smtp-verify smtp-help
|
|
smtp-transactions
|
|
smtp-transactions/no-close
|
|
smtp-connect
|
|
smtp-helo smtp-mail smtp-rcpt smtp-data
|
|
smtp-send smtp-soml smtp-saml smtp-rset smtp-expn
|
|
smtp-help smtp-noop smtp-quit smtp-turn))
|
|
|
|
(define-interface rfc822-interface
|
|
(export read-rfc822-headers
|
|
read-rfc822-headers-with-line-breaks
|
|
read-rfc822-field
|
|
read-rfc822-field-with-line-breaks
|
|
rfc822-time->string))
|
|
|
|
(define-interface uri-interface
|
|
(export parse-uri
|
|
uri-escaped-chars
|
|
unescape-uri
|
|
escape-uri
|
|
split-uri
|
|
uri-path->uri
|
|
simplify-uri-path))
|
|
|
|
(define-interface url-interface
|
|
(export server?
|
|
make-server
|
|
|
|
server-user
|
|
server-password
|
|
server-host
|
|
server-port
|
|
|
|
parse-server
|
|
server->string
|
|
|
|
http-url?
|
|
make-http-url
|
|
|
|
http-url-server
|
|
http-url-path
|
|
http-url-search
|
|
http-url-fragment-identifier
|
|
|
|
parse-http-url
|
|
parse-http-url-string
|
|
http-url->string))
|
|
|
|
(define-interface ftp-library-interface
|
|
(export copy-port->port-binary
|
|
copy-port->port-ascii
|
|
copy-ascii-port->port
|
|
parse-port-arg))
|
|
|
|
(define-interface ftp-interface
|
|
(export ftp-connect
|
|
(ftp-type :syntax)
|
|
ftp-set-type!
|
|
ftp-rename
|
|
ftp-delete
|
|
ftp-cd
|
|
ftp-cdup
|
|
ftp-pwd
|
|
ftp-rmdir
|
|
ftp-mkdir
|
|
ftp-modification-time
|
|
ftp-size
|
|
ftp-abort
|
|
ftp-quit
|
|
ftp-ls
|
|
ftp-dir
|
|
ftp-get
|
|
ftp-put
|
|
ftp-append
|
|
ftp-quot
|
|
ftp-error?
|
|
|
|
copy-port->port-binary
|
|
copy-port->port-ascii
|
|
copy-ascii-port->port))
|
|
|
|
(define-interface netrc-interface
|
|
(export netrc-machine-entry
|
|
netrc-entry?
|
|
netrc-entry-machine
|
|
netrc-entry-login
|
|
netrc-entry-password
|
|
netrc-entry-account
|
|
netrc-macro-definitions))
|
|
|
|
(define-interface pop3-interface
|
|
(export pop3-connect
|
|
pop3-stat
|
|
pop3-retrieve-message
|
|
pop3-retrieve-headers
|
|
pop3-last
|
|
pop3-delete
|
|
pop3-reset
|
|
pop3-quit
|
|
pop3-error?))
|
|
|
|
(define-interface rfc868-interface
|
|
(export rfc868-time/tcp rfc868-time/udp))
|
|
|
|
(define-interface rfc867-interface
|
|
(export rfc867-daytime/tcp rfc867-daytime/udp))
|
|
|
|
(define-interface dns-interface
|
|
(export dns-clear-cache! ; clears the cache
|
|
dns-lookup ; complex lookup function
|
|
dns-lookup-name ; simple lookup function
|
|
dns-inverse-lookup ; obsolete, use dns-lookup-ip
|
|
dns-lookup-ip ; simple lookup function
|
|
dns-lookup-nameserver ; simple lookup function
|
|
dns-lookup-mail-exchanger ; simple lookpu function
|
|
pretty-print-dns-message ; prints a human readable dns-msg
|
|
force-ip ; reruns a lookup until a ip is resolved
|
|
force-ip-list ; reruns a lookup until a list of ips is resolved
|
|
address32->ip-string ; converts a address32 in an ip-string
|
|
ip-string->address32 ; converts a ip-string in an address32
|
|
dns-find-nameserver ; returns a nameserver
|
|
dns-find-nameserver-list ; returns a list of nameservers
|
|
socket-address->fqdn
|
|
host-fqdn
|
|
system-fqdn))
|
|
|
|
(define-interface ips-interface
|
|
(export address32->ip-string
|
|
ip-string->address32
|
|
ip-string->in-addr.arpa-string
|
|
octet-ip->address32 ;for dns.scm
|
|
ip-string?))
|
|
|
|
(define-interface cgi-scripts-interface
|
|
(export cgi-form-query))
|
|
|
|
;; Utility libraries
|
|
|
|
(define-interface rate-limit-interface
|
|
(export make-rate-limiter
|
|
rate-limit-block
|
|
rate-limit-open
|
|
rate-limit-close
|
|
rate-limiter-current-requests))
|
|
|
|
(define-interface crlf-io-interface
|
|
(export read-crlf-line
|
|
read-crlf-line-timeout
|
|
write-crlf))
|
|
|
|
(define-interface ls-interface
|
|
(export ls-crlf?
|
|
ls
|
|
arguments->ls-flags))
|
|
|
|
(define-interface format-net-interface
|
|
(export format-internet-host-address
|
|
format-port))
|
|
|
|
(define-interface sunet-utilities-interface
|
|
(export host-name-or-ip
|
|
on-interrupt
|
|
socket-address->string
|
|
dump
|
|
copy-inport->outport
|
|
dotdot-check
|
|
with-lock
|
|
get-header))
|
|
|
|
(define-interface handle-fatal-error-interface
|
|
(export with-fatal-error-handler*
|
|
(with-fatal-error-handler :syntax)))
|
|
|
|
;; FTP server
|
|
|
|
(define-interface ftpd-interface
|
|
(export with-port with-anonymous-home with-banner with-log-port with-dns-lookup?
|
|
make-ftpd-options
|
|
ftpd
|
|
ftpd-inetd))
|
|
|
|
;; Web server
|
|
|
|
(define-interface httpd-core-interface
|
|
(export httpd))
|
|
|
|
(define-interface httpd-make-options-interface
|
|
(export make-httpd-options
|
|
with-port
|
|
with-root-directory
|
|
with-fqdn
|
|
with-reported-port
|
|
with-request-handler
|
|
with-server-admin
|
|
with-simultaneous-requests
|
|
with-log-file
|
|
with-syslog?
|
|
with-resolve-ips?
|
|
with-post-bind-thunk))
|
|
|
|
(define-interface httpd-read-options-interface
|
|
(export httpd-options-port
|
|
httpd-options-root-directory
|
|
httpd-options-fqdn
|
|
httpd-options-reported-port
|
|
httpd-options-request-handler
|
|
httpd-options-server-admin
|
|
httpd-options-simultaneous-requests
|
|
httpd-options-log-file
|
|
httpd-options-syslog?
|
|
httpd-options-resolve-ips?
|
|
httpd-options-post-bind-thunk))
|
|
|
|
(define-interface httpd-access-control-interface
|
|
(export access-denier
|
|
access-allower
|
|
access-controller
|
|
access-controlled-handler))
|
|
|
|
(define-interface httpd-errors-interface
|
|
(export http-error?
|
|
http-error
|
|
fatal-syntax-error?
|
|
fatal-syntax-error))
|
|
|
|
(define-interface httpd-logging-interface
|
|
(export init-http-log!
|
|
http-syslog?
|
|
http-syslog
|
|
http-log
|
|
logging
|
|
make-logging))
|
|
|
|
(define-interface httpd-requests-interface
|
|
(export make-request ; HTTP request
|
|
request? ; record type.
|
|
request-method
|
|
request-uri
|
|
request-url
|
|
request-version
|
|
request-headers
|
|
request-socket
|
|
|
|
version< version<=
|
|
v0.9-request?
|
|
version->string))
|
|
|
|
(define-interface httpd-responses-interface
|
|
(export make-response response?
|
|
response-code
|
|
response-message
|
|
response-seconds
|
|
response-mime
|
|
response-extras
|
|
response-body
|
|
|
|
make-nph-response nph-response?
|
|
nph-response-body
|
|
|
|
make-input-response input-response?
|
|
input-response-body-maker
|
|
|
|
make-writer-body writer-body?
|
|
make-reader-writer-body reader-writer-body?
|
|
make-redirect-body redirect-body? redirect-body-location
|
|
display-http-body
|
|
|
|
status-code?
|
|
status-code-number
|
|
status-code-message
|
|
(status-code :syntax)
|
|
name->status-code
|
|
number->status-code
|
|
|
|
make-error-response
|
|
make-redirect-response))
|
|
|
|
(define-interface httpd-basic-handlers-interface
|
|
(export make-predicate-handler
|
|
make-path-predicate-handler
|
|
make-host-name-handler
|
|
make-path-prefix-handler
|
|
alist-path-dispatcher
|
|
null-request-handler))
|
|
|
|
(define-interface httpd-file-directory-handlers-interface
|
|
(export home-dir-handler
|
|
tilde-home-dir-handler
|
|
rooted-file-handler
|
|
rooted-file-or-directory-handler
|
|
|
|
make-file-directory-options
|
|
with-file-name->content-type
|
|
with-file-name->content-encoding
|
|
with-file-name->icon-url
|
|
with-blank-icon-url
|
|
with-back-icon-url
|
|
with-unknown-icon-url))
|
|
|
|
(define-interface httpd-seval-handlers-interface
|
|
(export seval-handler))
|
|
|
|
(define-interface httpd-info-gateway-interface
|
|
(export info-handler
|
|
find-info-file
|
|
info-gateway-error))
|
|
|
|
(define-interface httpd-rman-gateway-interface
|
|
(export rman-handler
|
|
man
|
|
parse-man-entry
|
|
cat-man-page
|
|
find-man-file
|
|
file->man-directory
|
|
cat-n-decode
|
|
nroff-n-decode))
|
|
|
|
(define-interface httpd-cgi-handlers-interface
|
|
(export cgi-default-bin-path
|
|
cgi-handler))
|
|
|
|
(define-interface loser-interface (export loser))
|
|
|
|
(define-interface toothless-interface (interface-of scheme))
|
|
|
|
(define-interface toothless-eval-interface (export eval-safely))
|
|
|
|
;; Structures
|
|
|
|
(define-structure sunet-version (export sunet-version-identifier)
|
|
(open scheme)
|
|
(begin
|
|
(define sunet-version-identifier "2.0")))
|
|
|
|
;; Net protocols and formats
|
|
|
|
(define-structure parse-html-forms parse-html-forms-interface
|
|
(open scheme-with-scsh
|
|
let-opt
|
|
(subset srfi-13 (string-index string-map))
|
|
receiving
|
|
uri)
|
|
(files (lib parse-forms)))
|
|
|
|
(define-structure htmlout htmlout-interface
|
|
(open scheme-with-scsh
|
|
(subset srfi-13 (string-fold))
|
|
formats
|
|
ascii
|
|
receiving)
|
|
(files (lib htmlout)))
|
|
|
|
(define-structure smtp smtp-interface
|
|
(open scheme-with-scsh
|
|
signals conditions
|
|
define-record-types
|
|
(subset srfi-1 (filter-map))
|
|
(subset srfi-13 (string-tokenize string-join))
|
|
crlf-io ; read-crlf-line write-crlf
|
|
receiving ; values receive
|
|
dns ; SYSTEM-FQDN
|
|
let-opt
|
|
(subset rfc822 (rfc822-time->string)))
|
|
(files (lib smtp)))
|
|
|
|
(define-structure rfc822 rfc822-interface
|
|
(open scheme-with-scsh
|
|
receiving
|
|
(subset srfi-13 (string-map string-index string-concatenate))
|
|
let-opt
|
|
crlf-io
|
|
ascii)
|
|
(files (lib rfc822)))
|
|
|
|
(define-structure uri uri-interface
|
|
(open scheme-with-scsh
|
|
(subset srfi-13 (string-index string-index-right string-fold string-join))
|
|
let-opt
|
|
receiving
|
|
ascii
|
|
bitwise
|
|
field-reader-package)
|
|
(files (lib uri)))
|
|
|
|
(define-structure url url-interface
|
|
(open scheme-with-scsh
|
|
define-record-types
|
|
receiving
|
|
(subset srfi-13 (string-index))
|
|
uri
|
|
httpd-errors)
|
|
(files (lib url)))
|
|
|
|
(define-structure ftp-library ftp-library-interface
|
|
(open scheme-with-scsh
|
|
(subset signals (call-error))
|
|
(subset srfi-1 (any))
|
|
crlf-io)
|
|
(files (lib ftp-library)))
|
|
|
|
(define-structure ftp ftp-interface
|
|
(open scheme-with-scsh
|
|
netrc
|
|
define-record-types
|
|
finite-types
|
|
receiving
|
|
handle
|
|
conditions
|
|
signals
|
|
(subset srfi-13 (string-join string-prefix?))
|
|
let-opt
|
|
sunet-utilities
|
|
format-net
|
|
crlf-io
|
|
ftp-library)
|
|
(files (lib ftp)))
|
|
|
|
(define-structure netrc netrc-interface
|
|
(open scheme-with-scsh
|
|
define-record-types
|
|
srfi-14)
|
|
(files (lib netrc)))
|
|
|
|
(define-structure pop3 pop3-interface
|
|
(open scheme-with-scsh
|
|
netrc rfc822
|
|
define-record-types
|
|
handle
|
|
conditions handle-fatal-error
|
|
signals
|
|
(subset srfi-13 (string-index string-prefix? string-join))
|
|
let-opt
|
|
crlf-io)
|
|
(files (lib pop3)))
|
|
|
|
(define-structures ((rfc867 rfc867-interface)
|
|
(rfc868 rfc868-interface))
|
|
(open scheme-with-scsh
|
|
handle-fatal-error)
|
|
(files (lib nettime)))
|
|
|
|
(define-structure dns dns-interface
|
|
(open scheme-with-scsh
|
|
(subset srfi-1 (filter reverse! delete lset-difference lset-union))
|
|
tables
|
|
ascii
|
|
formats
|
|
signals
|
|
finite-types
|
|
define-record-types
|
|
random
|
|
queues
|
|
conditions
|
|
handle
|
|
sort
|
|
threads
|
|
locks
|
|
ips)
|
|
(files (lib dns)))
|
|
|
|
(define-structure ips ips-interface
|
|
(open scheme-with-scsh
|
|
formats)
|
|
(files (lib ip)))
|
|
|
|
(define-structure cgi-scripts cgi-scripts-interface
|
|
(open scheme-with-scsh
|
|
parse-html-forms)
|
|
(files (lib cgi-script)))
|
|
|
|
;; Utility libraries
|
|
|
|
(define-structure rate-limit rate-limit-interface
|
|
(open scheme
|
|
define-record-types
|
|
locks
|
|
signals)
|
|
(files (lib rate-limit)))
|
|
|
|
(define-structure crlf-io crlf-io-interface
|
|
(open scheme-with-scsh
|
|
ascii ; ascii->char
|
|
receiving ; MV return (RECEIVE and VALUES)
|
|
let-opt ; let-optionals
|
|
threads ; sleep
|
|
)
|
|
(files (lib crlf-io)))
|
|
|
|
(define-structure ls ls-interface
|
|
(open scheme-with-scsh
|
|
handle
|
|
(subset srfi-1 (filter))
|
|
bitwise
|
|
fluids
|
|
crlf-io)
|
|
(files (lib ls)))
|
|
|
|
(define-structure format-net format-net-interface
|
|
(open scheme-with-scsh
|
|
let-opt)
|
|
(files (lib format-net)))
|
|
|
|
(define-structure sunet-utilities sunet-utilities-interface
|
|
(open scheme-with-scsh
|
|
format-net
|
|
sigevents
|
|
(subset srfi-13 (string-join))
|
|
dns
|
|
let-opt ; :optional
|
|
locks
|
|
handle-fatal-error)
|
|
(files (lib sunet-utilities)))
|
|
|
|
(define-structure handle-fatal-error handle-fatal-error-interface
|
|
(open scheme conditions handle)
|
|
(files (lib handle-fatal-error)))
|
|
|
|
;; FTP server
|
|
|
|
(define-structure ftpd ftpd-interface
|
|
(open scheme-with-scsh
|
|
conditions handle signals
|
|
define-record-types
|
|
handle-fatal-error
|
|
threads threads-internal ; last one to get CURRENT-THREAD
|
|
fluids thread-fluids
|
|
locks
|
|
(subset srfi-13 (string-map string-trim-both string-index))
|
|
(subset srfi-1 (partition))
|
|
crlf-io
|
|
ls
|
|
ftp-library
|
|
dns
|
|
sunet-version
|
|
sunet-utilities
|
|
receiving
|
|
format-net)
|
|
(files (ftpd ftpd)))
|
|
|
|
;; Web server
|
|
|
|
(define-structure httpd-core httpd-core-interface
|
|
(open scheme-with-scsh
|
|
thread-fluids ; fork-thread
|
|
receiving
|
|
crlf-io ; write-crlf, read-crlf-line
|
|
rfc822
|
|
handle ; ignore-errors
|
|
conditions ; condition-stuff
|
|
uri
|
|
url
|
|
format-net
|
|
rate-limit ; rate-limiting stuff
|
|
(subset srfi-13 (string-index))
|
|
dns ; dns-lookup-ip
|
|
sunet-utilities ; socket-address->string
|
|
locks ; make-lock et al.
|
|
fluids ; let-fluid
|
|
enumerated ; enum
|
|
architecture ; os-error
|
|
|
|
handle-fatal-error
|
|
httpd-read-options
|
|
httpd-errors
|
|
httpd-logging
|
|
httpd-requests
|
|
httpd-responses
|
|
|
|
sunet-version
|
|
)
|
|
(files (httpd core)))
|
|
|
|
(define-structures ((httpd-make-options httpd-make-options-interface)
|
|
(httpd-read-options httpd-read-options-interface))
|
|
(open scheme
|
|
define-record-types)
|
|
(files (httpd options)))
|
|
|
|
(define-structure httpd (compound-interface httpd-core-interface
|
|
httpd-make-options-interface)
|
|
(open httpd-core
|
|
httpd-make-options))
|
|
|
|
(define-structure httpd-access-control httpd-access-control-interface
|
|
(open scheme-with-scsh
|
|
(subset srfi-1 (any every))
|
|
httpd-responses
|
|
httpd-requests
|
|
httpd-errors
|
|
(subset srfi-13 (string-map))
|
|
)
|
|
(files (httpd access-control)))
|
|
|
|
(define-structure httpd-errors httpd-errors-interface
|
|
(open conditions signals handle scheme)
|
|
(files (httpd error)))
|
|
|
|
(define-structure httpd-logging httpd-logging-interface
|
|
(open scheme-with-scsh
|
|
httpd-read-options
|
|
i/o ; make-null-output-port
|
|
locks
|
|
receiving
|
|
uri ; uri-path->uri
|
|
url ; http-url-path
|
|
httpd-requests ; request record
|
|
httpd-responses
|
|
formats
|
|
format-net ; format-internet-host-address
|
|
(subset srfi-13 (string-join string-trim))
|
|
rfc822 ; get-header
|
|
sunet-utilities ; on-interrupt
|
|
threads ; spawn
|
|
dns ; dns-lookup-ip
|
|
define-record-types
|
|
thread-fluids ; make-preserved-fluid et al.
|
|
handle-fatal-error
|
|
)
|
|
(files (httpd logging)))
|
|
|
|
(define-structure httpd-requests httpd-requests-interface
|
|
(open scheme
|
|
define-record-types)
|
|
(files (httpd request)))
|
|
|
|
(define-structure httpd-responses httpd-responses-interface
|
|
(open scheme
|
|
(subset scsh (format-date write-string time date))
|
|
syslog
|
|
define-record-types
|
|
finite-types
|
|
formats
|
|
(subset signals (call-error))
|
|
httpd-requests
|
|
httpd-read-options)
|
|
(files (httpd response)))
|
|
|
|
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
|
(open scheme-with-scsh
|
|
rfc822
|
|
httpd-requests ; REQUEST record type, v0.9-request
|
|
(subset srfi-1 (fold-right))
|
|
(subset srfi-13 (string-trim string-prefix-ci?))
|
|
httpd-responses
|
|
httpd-errors
|
|
)
|
|
(files (httpd handlers)))
|
|
|
|
(define-structure httpd-file-directory-handlers httpd-file-directory-handlers-interface
|
|
(open scheme-with-scsh
|
|
define-record-types
|
|
httpd-core
|
|
httpd-requests
|
|
httpd-responses
|
|
httpd-errors
|
|
httpd-basic-handlers
|
|
httpd-read-options
|
|
url
|
|
htmlout
|
|
crlf-io
|
|
(subset srfi-13 (string-join))
|
|
(subset rfc822 (rfc822-time->string))
|
|
sunet-utilities ; dotdot-check, copy-inport->outport
|
|
conditions
|
|
let-opt
|
|
handle-fatal-error
|
|
)
|
|
(files (httpd file-dir-handler)))
|
|
|
|
(define-structure httpd-seval-handlers httpd-seval-handlers-interface
|
|
(open scheme-with-scsh ; syscalls & INDEX
|
|
httpd-errors
|
|
httpd-requests ; v0.9-request
|
|
httpd-responses
|
|
httpd-logging ; http-log
|
|
uri ; UNESCAPE-URI
|
|
htmlout ; Formatted HTML output
|
|
pp
|
|
(subset srfi-13 (string-skip))
|
|
rfc822
|
|
toothless-eval ; EVAL-SAFELY
|
|
handle ; IGNORE-ERROR
|
|
parse-html-forms ; PARSE-HTML-FORM-QUERY
|
|
threads ; SLEEP
|
|
sunet-utilities ; GET-HEADER
|
|
)
|
|
(files (httpd seval)))
|
|
|
|
(define-structure httpd-info-gateway httpd-info-gateway-interface
|
|
(open scheme-with-scsh
|
|
(subset srfi-1 (find))
|
|
(subset srfi-13 (string-map string-skip string-index))
|
|
conditions signals handle
|
|
htmlout
|
|
httpd-requests
|
|
httpd-responses
|
|
httpd-errors
|
|
url
|
|
uri
|
|
handle-fatal-error)
|
|
(files (httpd info-gateway)))
|
|
|
|
(define-structure httpd-rman-gateway httpd-rman-gateway-interface
|
|
(open scheme-with-scsh
|
|
httpd-responses
|
|
httpd-requests
|
|
httpd-errors
|
|
conditions
|
|
url
|
|
uri
|
|
htmlout
|
|
httpd-basic-handlers
|
|
handle-fatal-error
|
|
let-opt
|
|
sunet-utilities
|
|
(subset srfi-13 (string-join))
|
|
)
|
|
(files (httpd rman-gateway)))
|
|
|
|
(define-structure httpd-cgi-handlers httpd-cgi-handlers-interface
|
|
(open scheme-with-scsh
|
|
(subset srfi-1 (alist-delete))
|
|
(subset srfi-13 (string-prefix? string-index string-trim substring/shared))
|
|
rfc822
|
|
crlf-io ; WRITE-CRLF
|
|
uri
|
|
url ; HTTP-URL record type
|
|
httpd-logging
|
|
httpd-requests
|
|
httpd-responses
|
|
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
|
httpd-errors ; HTTP-ERROR
|
|
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
|
|
sunet-version
|
|
formats
|
|
format-net
|
|
sunet-utilities ; host-name-or-empty, get-header
|
|
let-opt ; let-optionals
|
|
handle-fatal-error
|
|
)
|
|
(files (httpd cgi-server)))
|
|
|
|
(define-structure loser (export loser)
|
|
(open scheme signals)
|
|
(begin (define (loser name)
|
|
(lambda x (error "Illegal call" name)))))
|
|
|
|
(define-structure toothless toothless-interface
|
|
(open scheme loser)
|
|
(begin
|
|
(define call-with-input-file (loser "call-with-input-file"))
|
|
(define call-with-output-file (loser "call-with-output-file"))
|
|
(define load (loser "load"))
|
|
(define open-input-file (loser "open-input-file"))
|
|
(define open-output-file (loser "open-output-file"))
|
|
(define transcript-on (loser "transcript-on"))
|
|
(define with-input-from-file (loser "with-input-from-file"))
|
|
(define with-input-to-file (loser "with-input-to-file"))
|
|
(define eval (loser "eval"))
|
|
(define interaction-environment (loser "interaction-environment"))
|
|
(define scheme-report-environment (loser "scheme-report-environment"))))
|
|
|
|
(define-structure toothless-eval toothless-eval-interface
|
|
(open scheme
|
|
package-commands-internal ; config-package, get-reflective-tower
|
|
packages ; structure-package, make-simple-package
|
|
environments ; environment-ref
|
|
handle ; ignore-errors
|
|
)
|
|
(access toothless) ; Force it to be loaded.
|
|
(begin
|
|
|
|
(define toothless-struct (environment-ref (config-package) 'toothless))
|
|
(define toothless-package (structure-package toothless-struct))
|
|
|
|
(define (new-safe-package)
|
|
(make-simple-package (list toothless-struct) #t
|
|
(get-reflective-tower toothless-package) ; ???
|
|
'safe-env))
|
|
|
|
(define (eval-safely exp)
|
|
(ignore-errors (lambda () (eval exp (new-safe-package)))))))
|