375 lines
8.8 KiB
Scheme
375 lines
8.8 KiB
Scheme
|
;;; Scheme 48 module definitions for TCP/IP protocol suites.
|
||
|
|
;;; Copyright (c) 1995 by Olin Shivers.
|
||
|
|
|
||
|
|
(define-structures
|
||
|
|
((smtp (export sendmail %sendmail
|
||
|
|
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
|
||
|
|
handle-smtp-reply
|
||
|
|
read-smtp-reply
|
||
|
|
parse-smtp-reply
|
||
|
|
smtp-stuff))
|
||
|
|
(smtp-internals (export read-crlf-line ; These two should be in an
|
||
|
|
write-crlf ; auxiliary module.
|
||
|
|
|
||
|
|
smtp-query
|
||
|
|
nullary-smtp-command
|
||
|
|
unary-smtp-command)))
|
||
|
|
|
||
|
|
|
||
|
|
(open scsh ; write-string read-string/partial force-output
|
||
|
|
; system-name user-login-name and sockets
|
||
|
|
crlf-io ; read-crlf-line write-crlf
|
||
|
|
receiving ; values receive
|
||
|
|
let-opt ; let-optionals
|
||
|
|
error-package ; error
|
||
|
|
switch-syntax ; switchq
|
||
|
|
condhax ; ? for COND
|
||
|
|
scheme)
|
||
|
|
(files smtp))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structure crlf-io (export read-crlf-line
|
||
|
|
write-crlf)
|
||
|
|
(open ascii ; ascii->char
|
||
|
|
scsh ; read-line write-string force-output
|
||
|
|
receiving ; MV return (RECEIVE and VALUES)
|
||
|
|
let-opt ; let-optionals
|
||
|
|
scheme)
|
||
|
|
(files crlf-io))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structures ((switch-syntax (export (switch :syntax)
|
||
|
|
(switchq :syntax)))
|
||
|
|
(condhax (export (when :syntax)
|
||
|
|
(unless :syntax)
|
||
|
|
(? :syntax))))
|
||
|
|
(open scheme)
|
||
|
|
(files conditionals))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structure rfc822 (export read-rfc822-headers
|
||
|
|
read-rfc822-field
|
||
|
|
%read-rfc822-headers
|
||
|
|
%read-rfc822-field
|
||
|
|
rejoin-header-lines
|
||
|
|
get-header-all
|
||
|
|
get-header-lines
|
||
|
|
get-header
|
||
|
|
)
|
||
|
|
(open receiving ; MV return (RECEIVE and VALUES)
|
||
|
|
condhax ; ? for COND
|
||
|
|
scsh-utilities ; index
|
||
|
|
let-opt ; let-optionals
|
||
|
|
strings ; lowercase-string uppercase-string
|
||
|
|
crlf-io ; read-crlf-line
|
||
|
|
ascii ; ascii->char
|
||
|
|
error-package ; error
|
||
|
|
scsh ; join-strings
|
||
|
|
scheme)
|
||
|
|
(files rfc822))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structure strings (export string-map
|
||
|
|
downcase-string
|
||
|
|
upcase-string
|
||
|
|
char-set-index
|
||
|
|
char-set-rindex
|
||
|
|
string-reduce
|
||
|
|
skip-whitespace
|
||
|
|
string-prefix?
|
||
|
|
string-suffix?)
|
||
|
|
(open char-set-package let-opt scheme)
|
||
|
|
(files stringhax))
|
||
|
|
|
||
|
|
(define-structure uri-package (export parse-uri
|
||
|
|
uri-escaped-chars
|
||
|
|
unescape-uri
|
||
|
|
escape-uri
|
||
|
|
resolve-uri
|
||
|
|
split-uri-path
|
||
|
|
uri-path-list->path
|
||
|
|
simplify-uri-path)
|
||
|
|
(open scsh-utilities
|
||
|
|
let-opt
|
||
|
|
receiving
|
||
|
|
condhax
|
||
|
|
ascii
|
||
|
|
strings
|
||
|
|
char-set-package
|
||
|
|
bitwise
|
||
|
|
field-reader-package
|
||
|
|
scheme)
|
||
|
|
(files uri))
|
||
|
|
|
||
|
|
(define-structure url-package (export userhost? ; USERHOST
|
||
|
|
make-userhost ; record struct
|
||
|
|
|
||
|
|
userhost:user
|
||
|
|
userhost:password
|
||
|
|
userhost:host
|
||
|
|
userhost:port
|
||
|
|
|
||
|
|
set-userhost:user
|
||
|
|
set-userhost:password
|
||
|
|
set-userhost:host
|
||
|
|
set-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
|
||
|
|
|
||
|
|
set-http-url:userhost
|
||
|
|
set-http-url:path
|
||
|
|
set-http-url:search
|
||
|
|
set-http-url:frag-id
|
||
|
|
|
||
|
|
parse-http-url ; parse &
|
||
|
|
http-url->string) ; unparse.
|
||
|
|
|
||
|
|
(open defrec-package
|
||
|
|
receiving
|
||
|
|
condhax
|
||
|
|
char-set-package
|
||
|
|
uri-package
|
||
|
|
scsh-utilities
|
||
|
|
httpd-error
|
||
|
|
scheme)
|
||
|
|
(files url))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structure httpd-error (export http-error?
|
||
|
|
http-error
|
||
|
|
fatal-syntax-error?
|
||
|
|
fatal-syntax-error
|
||
|
|
with-fatal-error-handler*
|
||
|
|
(with-fatal-error-handler :syntax))
|
||
|
|
(open conditions signals handle scheme)
|
||
|
|
(files httpd-error))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structure httpd-core (export server/version
|
||
|
|
server/protocol
|
||
|
|
server/admin
|
||
|
|
set-server/admin!
|
||
|
|
|
||
|
|
http-log
|
||
|
|
*http-log?*
|
||
|
|
*http-log-port*
|
||
|
|
|
||
|
|
httpd
|
||
|
|
|
||
|
|
make-request ; HTTP request
|
||
|
|
request? ; record type.
|
||
|
|
request:method
|
||
|
|
request:uri
|
||
|
|
request:url
|
||
|
|
request:version
|
||
|
|
request:headers
|
||
|
|
request:socket
|
||
|
|
set-request:method
|
||
|
|
set-request:uri
|
||
|
|
set-request:url
|
||
|
|
set-request:version
|
||
|
|
set-request:headers
|
||
|
|
set-request:socket
|
||
|
|
|
||
|
|
version< version<=
|
||
|
|
v0.9-request?
|
||
|
|
version->string
|
||
|
|
|
||
|
|
;; Integer reply codes
|
||
|
|
reply-code->text
|
||
|
|
http-reply/ok
|
||
|
|
http-reply/created
|
||
|
|
http-reply/accepted
|
||
|
|
http-reply/prov-info
|
||
|
|
http-reply/no-content
|
||
|
|
http-reply/mult-choice
|
||
|
|
http-reply/moved-perm
|
||
|
|
http-reply/moved-temp
|
||
|
|
http-reply/method
|
||
|
|
http-reply/not-mod
|
||
|
|
http-reply/bad-request
|
||
|
|
http-reply/unauthorized
|
||
|
|
http-reply/payment-req
|
||
|
|
http-reply/forbidden
|
||
|
|
http-reply/not-found
|
||
|
|
http-reply/method-not-allowed
|
||
|
|
http-reply/none-acceptable
|
||
|
|
http-reply/proxy-auth-required
|
||
|
|
http-reply/timeout
|
||
|
|
http-reply/conflict
|
||
|
|
http-reply/gone
|
||
|
|
http-reply/internal-error
|
||
|
|
http-reply/not-implemented
|
||
|
|
http-reply/bad-gateway
|
||
|
|
http-reply/service-unavailable
|
||
|
|
http-reply/gateway-timeout
|
||
|
|
|
||
|
|
time->http-date-string
|
||
|
|
begin-http-header
|
||
|
|
send-http-error-reply
|
||
|
|
|
||
|
|
set-my-fqdn!
|
||
|
|
set-my-port!)
|
||
|
|
(open scsh
|
||
|
|
receiving
|
||
|
|
let-opt
|
||
|
|
crlf-io
|
||
|
|
rfc822
|
||
|
|
switch-syntax
|
||
|
|
condhax
|
||
|
|
strings
|
||
|
|
char-set-package
|
||
|
|
defrec-package
|
||
|
|
handle
|
||
|
|
conditions ; condition-stuff
|
||
|
|
defenum-package
|
||
|
|
httpd-error
|
||
|
|
uri-package
|
||
|
|
url-package
|
||
|
|
formats
|
||
|
|
scheme)
|
||
|
|
(files httpd-core))
|
||
|
|
|
||
|
|
|
||
|
|
;;; For parsing submissions from HTML forms.
|
||
|
|
(define-structure parse-html-forms (export parse-html-form-query unescape-uri+)
|
||
|
|
(open scsh scsh-utilities let-opt
|
||
|
|
receiving uri-package strings condhax scheme)
|
||
|
|
(files parse-forms))
|
||
|
|
|
||
|
|
|
||
|
|
;;; For writing CGI scripts in Scheme.
|
||
|
|
(define-structure cgi-script-package (export cgi-form-query)
|
||
|
|
(open scsh
|
||
|
|
switch-syntax
|
||
|
|
error-package
|
||
|
|
parse-html-forms
|
||
|
|
scheme)
|
||
|
|
(files cgi-script))
|
||
|
|
|
||
|
|
;;; Provides the server interface to CGI scripts.
|
||
|
|
(define-structure cgi-server-package (export cgi-default-bin-path
|
||
|
|
cgi-handler
|
||
|
|
initialise-request-invariant-cgi-env)
|
||
|
|
(open strings
|
||
|
|
rfc822
|
||
|
|
crlf-io ; WRITE-CRLF
|
||
|
|
uri-package
|
||
|
|
url-package ; HTTP-URL record type
|
||
|
|
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes
|
||
|
|
; version stuff
|
||
|
|
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
||
|
|
httpd-error ; HTTP-ERROR
|
||
|
|
scsh-utilities ; INDEX
|
||
|
|
scsh ; syscalls
|
||
|
|
formats ; format
|
||
|
|
condhax ; ? is COND
|
||
|
|
switch-syntax ; SWITCHQ
|
||
|
|
scheme)
|
||
|
|
(files cgi-server))
|
||
|
|
|
||
|
|
(define-structure htmlout-package (export emit-tag
|
||
|
|
emit-close-tag
|
||
|
|
|
||
|
|
emit-p
|
||
|
|
emit-title
|
||
|
|
emit-header ; And so forth...
|
||
|
|
|
||
|
|
with-tag
|
||
|
|
with-tag*
|
||
|
|
|
||
|
|
escape-html
|
||
|
|
emit-text)
|
||
|
|
(open scsh scsh-utilities strings formats ascii receiving scheme)
|
||
|
|
(files htmlout))
|
||
|
|
|
||
|
|
(define-structure httpd-basic-handlers (export alist-path-dispatcher
|
||
|
|
home-dir-handler
|
||
|
|
tilde-home-dir-handler
|
||
|
|
rooted-file-handler
|
||
|
|
rooted-file-or-directory-handler
|
||
|
|
null-path-handler
|
||
|
|
serve-rooted-file-path
|
||
|
|
file-serve
|
||
|
|
file-server-and-dir
|
||
|
|
http-homedir
|
||
|
|
send-file
|
||
|
|
dotdot-check
|
||
|
|
file-extension->content-type
|
||
|
|
copy-inport->outport)
|
||
|
|
(open scsh ; syscalls
|
||
|
|
formats ; FORMAT
|
||
|
|
condhax ; UNLESS, ? for COND
|
||
|
|
switch-syntax ; Conditionals
|
||
|
|
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
||
|
|
; v0.9-request, begin-http-header
|
||
|
|
httpd-error
|
||
|
|
htmlout-package
|
||
|
|
conditions ; CONDITION-STUFF
|
||
|
|
url-package ; HTTP-URL record type
|
||
|
|
scheme)
|
||
|
|
(files httpd-handlers))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structure seval-handler-package (export seval-handler)
|
||
|
|
(open scsh ; syscalls & INDEX
|
||
|
|
condhax ; WHEN, ? for COND
|
||
|
|
switch-syntax ; Conditionals
|
||
|
|
httpd-error
|
||
|
|
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
||
|
|
; v0.9-request, reply formatting stuff.
|
||
|
|
uri-package ; UNESCAPE-URI
|
||
|
|
htmlout-package ; Formatted HTML output
|
||
|
|
error-package ; ERROR
|
||
|
|
pp ; Pretty-printer
|
||
|
|
strings rfc822
|
||
|
|
toothless-eval ; EVAL-SAFELY
|
||
|
|
handle ; IGNORE-ERROR
|
||
|
|
strings ; SKIP-WHITESPACE
|
||
|
|
parse-html-forms ; PARSE-HTML-FORM-QUERY
|
||
|
|
scheme)
|
||
|
|
(files seval))
|
||
|
|
|
||
|
|
(define-structure httpd-access-control (export access-denier
|
||
|
|
access-allower
|
||
|
|
access-controller
|
||
|
|
access-controlled-handler)
|
||
|
|
(open big-scheme
|
||
|
|
strings
|
||
|
|
httpd-core
|
||
|
|
httpd-error
|
||
|
|
scsh
|
||
|
|
scheme)
|
||
|
|
(files httpd-access-control))
|
||
|
|
|
||
|
|
(define-structure info-gateway (export info-handler
|
||
|
|
find-info-file
|
||
|
|
info-gateway-error)
|
||
|
|
(open big-scheme
|
||
|
|
conditions signals handle
|
||
|
|
switch-syntax
|
||
|
|
condhax
|
||
|
|
strings
|
||
|
|
htmlout-package
|
||
|
|
httpd-core
|
||
|
|
httpd-error
|
||
|
|
url-package
|
||
|
|
uri-package
|
||
|
|
scsh
|
||
|
|
scheme)
|
||
|
|
(files info-gateway))
|