sunet/scheme/packages.scm

877 lines
20 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 send-mail-via-smtp
expn vrfy mail-help
smtp-transactions
smtp-transactions/no-close
smtp/open 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-field
%read-rfc822-headers
%read-rfc822-field
rejoin-header-lines
get-header-all
get-header-lines
get-header
delete-headers
))
(define-interface uri-interface
(export parse-uri
uri-escaped-chars
unescape-uri
escape-uri
resolve-uri
split-uri-path
uri-path-list->path
simplify-uri-path))
(define-interface url-interface
(export userhost? ; USERHOST
make-userhost ; record struct
userhost-user
userhost-password
userhost-host
userhost-port
parse-userhost ; parse &
userhost->string ; unparse.
http-url? ; HTTP-URL
make-http-url ; record struct
http-url-userhost
http-url-path
http-url-search
http-url-frag-id
parse-http-url ; parse &
http-url->string))
(define-interface ftp-interface
(export ftp-connect
ftp-login
ftp-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?))
(define-interface ftp-obsolete-interface
(export ftp:connect
ftp:login
ftp: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))
(define-interface netrc-interface
(export user-mail-address
netrc-lookup
netrc-lookup-password
netrc-lookup-login
netrc-parse
netrc-try-parse
netrc-refuse?))
(define-interface pop3-interface
(export pop3-connect
pop3-login
pop3-stat
pop3-get
pop3-headers
pop3-last
pop3-delete
pop3-reset
pop3-quit))
(define-interface pop3-obsolete-interface
(export pop3:connect
pop3:login
pop3:stat
pop3:get
pop3:headers
pop3:last
pop3:delete
pop3:reset
pop3:quit))
(define-interface nettime-interface
(export net-time
net-daytime))
(define-interface nettime-obsolete-interface
(export net:time
net:daytime))
(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
show-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
internet-address->fqdn
host-fqdn
system-fqdn))
(define-interface cgi-script-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
system-fqdn
copy-inport->outport
dotdot-check
with-lock))
(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-logfile 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-icon-name
with-fqdn
with-reported-port
with-request-handler
with-server-admin
with-simultaneous-requests
with-logfile
with-syslog?
with-resolve-ips?))
(define-interface httpd-read-options-interface
(export httpd-options-port
httpd-options-root-directory
httpd-options-icon-name
httpd-options-fqdn
httpd-options-reported-port
httpd-options-request-handler
httpd-options-server-admin
httpd-options-simultaneous-requests
httpd-options-logfile
httpd-options-syslog?
httpd-options-resolve-ips?))
(define-interface httpd-access-control-interface
(export access-denier
access-allower
access-controller
access-controlled-handler))
(define-interface httpd-error-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-writer-body writer-body?
make-reader-writer-body reader-writer-body?
make-redirect-body redirect-body? redirect-body-location
display-http-body
;; Integer reply codes
status-code->text
http-status/ok
http-status/created
http-status/accepted
http-status/prov-info
http-status/no-content
http-status/mult-choice
http-status/moved-perm
http-status/moved-temp
http-status/method
http-status/not-mod
http-status/bad-request
http-status/unauthorized
http-status/payment-req
http-status/forbidden
http-status/not-found
http-status/method-not-allowed
http-status/none-acceptable
http-status/proxy-auth-required
http-status/timeout
http-status/conflict
http-status/gone
http-status/internal-error
http-status/not-implemented
http-status/bad-gateway
http-status/service-unavailable
http-status/gateway-timeout
http-status/redirect ; used internally
make-http-error-response
make-redirect-response
time->http-date-string))
(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))
(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
; user-login-name and sockets
(subset srfi-1 (filter-map))
crlf-io ; read-crlf-line write-crlf
receiving ; values receive
let-opt ; let-optionals
error-package ; error
dns ; SYSTEM-FQDN
)
(files (lib smtp)))
(define-structure rfc822 rfc822-interface
(open scheme-with-scsh
receiving ; MV return (RECEIVE and VALUES)
(subset srfi-13 (string-map string-index string-join))
(subset srfi-1 (fold))
let-opt ; let-optionals
crlf-io ; read-crlf-line
ascii ; ascii->char
error-package ; error
)
(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-error)
(files (lib url)))
(define-structure ftp ftp-interface
(open scheme-with-scsh
netrc
define-record-types
receiving
handle
conditions
signals
error-package
(subset srfi-13 (string-join))
let-opt
sunet-utilities
crlf-io)
(files (lib ftp)))
(define-structure ftp-obsolete ftp-obsolete-interface
(open scheme
ftp)
(begin
(define ftp:connect ftp-connect)
(define ftp:login ftp-login)
(define ftp:type ftp-type)
(define ftp:rename ftp-rename)
(define ftp:delete ftp-delete)
(define ftp:cd ftp-cd)
(define ftp:cdup ftp-cdup)
(define ftp:pwd ftp-pwd)
(define ftp:rmdir ftp-rmdir)
(define ftp:mkdir ftp-mkdir)
(define ftp:modification-time ftp-modification-time)
(define ftp:size ftp-size)
(define ftp:abort ftp-abort)
(define ftp:quit ftp-quit)
(define ftp:ls ftp-ls)
(define ftp:dir ftp-dir)
(define ftp:get ftp-get)
(define ftp:put ftp-put)
(define ftp:append ftp-append)
(define ftp:quot ftp-quot)))
(define-structure netrc netrc-interface
(open scheme-with-scsh
define-record-types
records
error-package
srfi-13
conditions signals handle
sunet-utilities
let-opt)
(files (lib netrc)))
(define-structure pop3 pop3-interface
(open scheme-with-scsh
netrc
define-record-types
handle
conditions
signals
(subset srfi-13 (string-index))
let-opt
crlf-io)
(files (lib pop3)))
(define-structure pop3-obsolete pop3-obsolete-interface
(open scheme
pop3)
(begin
(define pop3:connect pop3-connect)
(define pop3:login pop3-login)
(define pop3:stat pop3-stat)
(define pop3:get pop3-get)
(define pop3:headers pop3-headers)
(define pop3:last pop3-last)
(define pop3:delete pop3-delete)
(define pop3:reset pop3-reset)
(define pop3:quit pop3-quit)))
(define-structure nettime nettime-interface
(open scheme-with-scsh)
(files (lib nettime)))
(define-structure nettime-obsolete nettime-obsolete-interface
(open scheme
nettime)
(begin
(define net:time net-time)
(define net:daytime net-daytime)))
(define-structure dns dns-interface
(open scheme-with-scsh
(subset srfi-1 (filter reverse! delete lset-difference lset-union))
tables
ascii
formats
signals
defrec-package
random
queues
conditions
handle
sort
threads
locks)
(files (lib dns)))
(define-structure cgi-script cgi-script-interface
(open scheme-with-scsh
error-package
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
let-opt
(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 (any partition))
crlf-io
ls
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 ; read-rfc822-headers
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-error
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-access-control httpd-access-control-interface
(open scheme-with-scsh
(subset srfi-1 (any every))
httpd-responses
httpd-requests
httpd-error
(subset srfi-13 (string-map))
)
(files (httpd access-control)))
(define-structure httpd-error httpd-error-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-list->path
url ; http-url-path
httpd-requests ; request record
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
defenum-package
formats
httpd-requests
httpd-logging
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))
httpd-responses
)
(files (httpd handlers)))
(define-structure httpd-file-directory-handlers httpd-file-directory-handlers-interface
(open scheme-with-scsh
httpd-core
httpd-requests
httpd-responses
httpd-error
httpd-basic-handlers
httpd-read-options
url
htmlout
crlf-io
(subset srfi-13 (string-join))
sunet-utilities ; dotdot-check, copy-inport->outport
conditions
handle-fatal-error
)
(files (httpd file-dir-handler)))
(define-structure httpd-seval-handlers httpd-seval-handlers-interface
(open scheme-with-scsh ; syscalls & INDEX
httpd-error
httpd-requests ; v0.9-request
httpd-responses
httpd-logging ; http-log
uri ; UNESCAPE-URI
htmlout ; Formatted HTML output
error-package ; ERROR ####
pp
(subset srfi-13 (string-skip))
rfc822
toothless-eval ; EVAL-SAFELY
handle ; IGNORE-ERROR
parse-html-forms ; PARSE-HTML-FORM-QUERY
threads ; SLEEP
)
(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-error
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-error
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-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-error ; HTTP-ERROR
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
sunet-version
formats
format-net
sunet-utilities ; host-name-or-empty
let-opt ; let-optionals
handle-fatal-error
)
(files (httpd cgi-server)))
(define-structure loser (export loser)
(open scheme error-package)
(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)))))))