sunet/modules.scm

702 lines
15 KiB
Scheme

;;; Scheme 48 module definitions for TCP/IP protocol suites.
;;; Copyright (c) 1995 by Olin Shivers.
(define-interface format-net-interface
(export format-internet-host-address
format-port))
(define-structure format-net format-net-interface
(open scsh
scheme
let-opt) ; :optional
(files format-net))
(define-interface sunet-utilities-interface
(export host-name-or-ip))
(define-structure sunet-utilities sunet-utilities-interface
(open scsh
scheme
format-net
handle-fatal-error)
(files sunet-utilities))
(define-interface smtp-interface
(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))
(define-interface smtp-internals-interface
(export read-crlf-line ; These two should be in an
write-crlf ; auxiliary module.
smtp-query
nullary-smtp-command
unary-smtp-command))
(define-structures
((smtp smtp-interface)
(smtp-internals smtp-internals-interface))
(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
scheme)
(files smtp))
(define-interface crlf-io-interface
(export read-crlf-line
read-crlf-line-timeout
write-crlf))
(define-structure crlf-io crlf-io-interface
(open ascii ; ascii->char
scsh ; read-line write-string force-output
receiving ; MV return (RECEIVE and VALUES)
let-opt ; let-optionals
threads ; sleep
scheme)
(files crlf-io))
(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
))
(define-structure rfc822 rfc822-interface
(open receiving ; MV return (RECEIVE and VALUES)
scsh-utilities ; index
string-lib
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-interface strings-interface
(export string-map
downcase-string
upcase-string
char-set-index
char-set-rindex
string-reduce
skip-whitespace
string-prefix?
string-suffix?
trim-spaces))
(define-structure strings strings-interface
(open char-set-lib let-opt scheme)
(files stringhax))
(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-structure uri uri-interface
(open scsh-utilities
string-lib
let-opt
receiving
ascii
strings
char-set-lib
bitwise
field-reader-package
scheme)
(files uri))
(define-interface url-interface
(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.
(define-structure url url-interface
(open defrec-package
receiving
string-lib
char-set-lib
uri
scsh-utilities
httpd-error
scheme)
(files url))
(define-interface httpd-error-interface
(export http-error?
http-error
fatal-syntax-error?
fatal-syntax-error))
(define-structure httpd-error httpd-error-interface
(open conditions signals handle scheme)
(files httpd-error))
(define-interface handle-fatal-error-interface
(export with-fatal-error-handler*
(with-fatal-error-handler :syntax)))
(define-structure handle-fatal-error handle-fatal-error-interface
(open scheme conditions handle)
(files handle-fatal-error))
(define-interface httpd-core-interface
(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!))
(define-structure httpd-core httpd-core-interface
(open threads
thread-fluids ; fork-thread
scsh
receiving
let-opt
crlf-io
rfc822
strings
char-set-lib
defrec-package
define-record-types
handle
conditions ; condition-stuff
defenum-package
httpd-error
handle-fatal-error
uri
url
formats
sunet-utilities
scheme)
(files httpd-core))
;;; For parsing submissions from HTML forms.
(define-interface parse-html-forms-interface
(export parse-html-form-query unescape-uri+))
(define-structure parse-html-forms parse-html-forms-interface
(open scsh scsh-utilities let-opt string-lib
receiving uri strings
scheme)
(files parse-forms))
;;; For writing CGI scripts in Scheme.
(define-interface cgi-script-interface (export cgi-form-query))
(define-structure cgi-script cgi-script-interface
(open scsh
error-package
parse-html-forms
scheme)
(files cgi-script))
;;; Provides the server interface to CGI scripts.
(define-interface cgi-server-interface
(export cgi-default-bin-path
cgi-handler
initialise-request-invariant-cgi-env))
(define-structure cgi-server cgi-server-interface
(open strings
string-lib
rfc822
crlf-io ; WRITE-CRLF
uri
url ; 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
format-net ; FORMAT-INTERNET-HOST-ADDRESS
sunet-utilities ; host-name-or-empty
scheme)
(files cgi-server))
(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-structure htmlout htmlout-interface
(open scsh scsh-utilities strings formats ascii receiving scheme)
(files htmlout))
(define-interface httpd-basic-handlers-interface
(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))
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
(open scsh ; syscalls
formats ; FORMAT
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
; v0.9-request, begin-http-header
httpd-error
htmlout
conditions ; CONDITION-STUFF
url ; HTTP-URL record type
handle-fatal-error ; WITH-FATAL-ERROR-HANDLER
string-lib ; STRING-JOIN
scheme)
(files httpd-handlers))
(define-interface seval-handler-interface
(export seval-handler))
(define-structure seval-handler seval-handler-interface
(open scsh ; syscalls & INDEX
httpd-error
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
; v0.9-request, reply formatting stuff.
uri ; UNESCAPE-URI
htmlout ; 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
threads ; SLEEP
scheme)
(files seval))
(define-interface httpd-access-control-interface
(export access-denier
access-allower
access-controller
access-controlled-handler))
(define-structure httpd-access-control httpd-access-control-interface
(open big-scheme
strings
httpd-core
httpd-error
scsh
scheme)
(files httpd-access-control))
(define-interface info-gateway-interface
(export info-handler
find-info-file
info-gateway-error))
(define-structure info-gateway info-gateway-interface
(open big-scheme
string-lib
conditions signals handle
strings
htmlout
httpd-core
httpd-error
url
uri
scsh
handle-fatal-error
scheme)
(files info-gateway))
(define-interface 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-structure rman-gateway rman-gateway-interface
(open httpd-core
httpd-error
conditions
url
uri
htmlout
httpd-basic-handlers
handle-fatal-error
scsh
let-opt
string-lib
scheme)
(files rman-gateway))
(define-interface ls-interface
(export ls
arguments->ls-flags))
(define-structure ls ls-interface
(open scheme handle
big-scheme bitwise
scsh)
(files ls))
(define-interface ftpd-interface
(export ftpd
ftpd-inetd))
(define-structure ftpd ftpd-interface
(open scheme
conditions handle signals
structure-refs
handle-fatal-error
scsh
threads threads-internal ; last one to get CURRENT-THREAD
thread-fluids ; fork-thread
fluids
string-lib
big-util
defrec-package
crlf-io strings ls
format-net) ; pretty print of internet-addresses
(access big-scheme)
(files ftpd))
;; some utilities for the following stuff
;; hope we can vanish this soon
(define-interface ecm-utilities-interface
(export system-fqdn
safe-first
safe-second
write-crlf
dump))
(define-structure ecm-utilities ecm-utilities-interface
(open scsh
string-lib
scheme)
(files ecm-utilities))
;; netrc.scm is a module for parsing ~/.netrc files, to obtain login
;; and password information for different network hosts.
(define-interface netrc-interface
(export user-mail-address
netrc:lookup
netrc:lookup-password
netrc:lookup-login
netrc:parse
netrc:try-parse
netrc-refuse?))
(define-structure netrc netrc-interface
(open defrec-package
records
scsh
error-package
ecm-utilities
string-lib
conditions signals handle
let-opt
scheme)
(files netrc))
;; ftp.scm is a module for transfering files between networked
;; machines using the File Transfer Protocol
(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))
(define-structure ftp ftp-interface
(open netrc
scsh
defrec-package
receiving
handle
conditions
signals
error-package
ecm-utilities
string-lib
let-opt
scheme)
(files ftp))
;; pop3.scm is a module for accessing email on a maildrop server,
;; using the POP3 protocol.
(define-interface pop3-interface
(export pop3:connect
pop3:login
pop3:stat
pop3:get
pop3:headers
pop3:last
pop3:delete
pop3:reset
pop3:quit))
(define-structure pop3 pop3-interface
(open netrc
scsh
defrec-package
handle
conditions
signals
ecm-utilities
string-lib
scheme)
(files pop3))
;; nettime.scm is a module for requesting the time on remote machines,
;; using the time or the daytime protocol
(define-interface nettime-interface
(export net:time
net:daytime))
(define-structure nettime nettime-interface
(open scsh
scheme)
(files nettime))
;;; Here is toothless.scm
;;; Shouldn't the definitions be in an extra file? Andreas.
;;; -*- Scheme -*-
;;; This file defines a Scheme 48 module that is R4RS without features that
;;; could examine or effect the file system. You can also use it
;;; as a model of how to execute code in other protected environments
;;; in S48.
;;;
;;; Copyright (c) 1995 by Olin Shivers.
(define-interface loser-interface (export loser))
(define-structure loser (export loser)
(open scheme error-package)
(begin (define (loser name)
(lambda x (error "Illegal call" name)))))
;;; The toothless structure is R4RS without the dangerous procedures.
(define-interface toothless-interface (interface-of scheme))
(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"))))
;;; (EVAL-SAFELEY exp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Create a brand new package, import the TOOTHLESS structure, and
;;; evaluate EXP in it. When the evaluation is done, you throw away
;;; the environment, so EXP's side-effects don't persist from one
;;; EVAL-SAFELY call to the next. If EXP raises an error exception,
;;; we abort and return #f.
(define-interface toothless-eval-interface (export eval-safely))
(define-structure toothless-eval toothless-eval-interface
(open evaluation ; eval
package-commands-internal ; config-package, get-reflective-tower
packages ; structure-package, make-simple-package
environments ; environment-ref
handle ; ignore-errors
scheme)
(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)))))))