sunet/modules.scm

;;; Scheme 48 module definitions for TCP/IP protocol suites. 
;;; Copyright (c) 1995 by Olin Shivers.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities / nice things
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; format-net

(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))

;;; sunet utilities
	
(define-interface sunet-utilities-interface
  (export host-name-or-ip
	  on-interrupt))

(define-structure sunet-utilities sunet-utilities-interface
  (open scsh
	scheme
	format-net
	sigevents
	handle-fatal-error)
  (files sunet-utilities))


;;; rate limit

(define-interface rate-limit-interface
  (export make-rate-limiter
	  rate-limit-block
	  rate-limit-open
	  rate-limit-close
	  rate-limiter-current-requests))

(define-structure rate-limit rate-limit-interface
  (open scheme
	define-record-types
	locks
	signals)
  (files rate-limit))
  


;;; CRLF-IO

(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))


;;; ecm utilities

;; some utilities for the ecm-stuff (ftp, pop3, smtp, nettime)
;; 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))


;;; parse-html-forms
;;; 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
	scheme)
  (files parse-forms))


;;; htmlout

(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 string-lib formats ascii receiving scheme)
  (files htmlout))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Clients / RFC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; SMTP

(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))


;;; RFC 822

(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
	crlf-io		; read-crlf-line
	ascii		; ascii->char
	error-package	; error
	scsh		; string-join
	scheme)
  (files rfc822))


;;; URI

(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
	char-set-lib
	bitwise
	field-reader-package
	scheme)
  (files uri))

;;; URL

(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))


;;; ftp client

;; 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
	  ftp-error?))

(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))

;; obsolete ftp client

(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-structure ftp-obsolete ftp-obsolete-interface
  (open scsh
	scheme
	ftp)
  (files ftp-obsolete))


;;; netrc parsing

;; 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))


;;; POP3 client
                
;; 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))

;; obsolete pop3

(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-structure pop3-obsolete pop3-obsolete-interface
  (open scsh
	scheme
	pop3)
  (files pop3-obsolete))

;;; nettime

;; 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))

;; obsolete nettime

(define-structure nettime-obsolete nettime-obsolete-interface
  (open scsh
	scheme
	nettime)
  (files nettime-obsolete))

(define-interface nettime-obsolete-interface
  (export net:time
	  net:daytime))


;;; ls
;; clone of unix' ls

(define-interface ls-interface 
  (export ls-crlf?
	  ls
	  arguments->ls-flags))

(define-structure ls ls-interface
  (open scheme handle
	big-scheme bitwise
	fluids
	crlf-io
	scsh)
  (files ls))


;;; DNS

;; dns.scm is a module to resolve hostnames and ip-addresses.
;; it implements the rfc1035.
(define-interface dns-interface
  (export dns-clear-cache
	  dns-lookup
	  dns-lookup-name
	  dns-inverse-lookup
	  dns-lookup-ip
	  dns-lookup-nameserver
	  dns-lookup-mail-exchanger
	  concurrent-lookup
	  show-dns-message
	  force-ip
	  force-ip-list
	  dns-find-nameserver
	  dns-find-nameserver-list))

(define-structure dns dns-interface
  (open scheme
	scsh
	big-util
	tables
	ascii
	formats
	signals
	defrec-package
	random
	queues
	conditions
	handle
	sort
	threads
	locks)
  (files dns))

;;; CGI script

;;; 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))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Servers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; HTTPD Web-Server

;;; httpd-core

(define-interface httpd-core-interface
  (export httpd
	  send-http-error-reply))

(define-structure httpd-core httpd-core-interface
  (open thread-fluids			; fork-thread
	scsh
	receiving			; receive
	crlf-io				; write-crlf, read-crlf-line
	rfc822				; read-rfc822-headers
	char-set-lib			; char-set-complement, char-set:whitespace 
	handle				; ignore-errors
	conditions			; condition-stuff
	uri
	url
	formats				; format
	format-net			; format-internet-host-address
	rate-limit			; rate-limiting stuff
	string-lib			; STRING-INDEX

	handle-fatal-error
	httpd-read-options
	httpd-error
	httpd-logging
	httpd-request
	httpd-reply-codes
	httpd-text-generation
	scheme)
  (files (httpd core)))


;;; httpd-make-options
;;; httpd-read-options

(define-interface httpd-make-options-interface
  (export with-port
	  with-root-directory
	  with-fqdn
	  with-reported-port
	  with-path-handler
	  with-server-admin
	  with-simultaneous-requests
	  with-logfile
	  with-syslog?))

(define-interface httpd-read-options-interface
  (export httpd-options-port
	  httpd-options-root-directory
	  httpd-options-fqdn
	  httpd-options-reported-port
	  httpd-options-path-handler
	  httpd-options-server-admin
	  httpd-options-simultaneous-requests
	  httpd-options-logfile
	  httpd-options-syslog?))

(define-structures ((httpd-make-options httpd-make-options-interface)
		    (httpd-read-options httpd-read-options-interface))
  (open scheme
	define-record-types)
  (files (httpd options)))


;;; httpd-access-control

(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
	httpd-reply-codes
	httpd-request
	httpd-error
	string-lib    ; STRING-MAP
	scsh
	scheme)
  (files (httpd access-control)))


;;; httpd-error

(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)))

;;; httpd-fatal-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 (httpd handle-fatal-error)))

;;; httpd-logging

(define-interface httpd-logging-interface
  (export init-http-log!
	  *http-syslog?*
	  http-syslog
	  http-log))

(define-structure httpd-logging httpd-logging-interface
  (open httpd-read-options
	i/o				; make-null-output-port
	locks				; make-lock obtain-lock release-lock
	receiving			; receive
	uri				; uri-path-list->path
	url				; http-url:path
	httpd-request			; request record
	formats				; format
	format-net			; format-internet-host-address
	string-lib			; string-join, string-trim
	rfc822				; get-header
	sunet-utilities			; on-interrupt
	threads				; spawn
	scsh
	scheme)
  (files (httpd logging)))

;; httpd-reply-codes

(define-interface httpd-reply-codes-interface
  (export ;; 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))

(define-structure httpd-reply-codes httpd-reply-codes-interface
  (open defenum-package
	scheme)
  (files (httpd reply-codes)))

;; httpd-request

(define-interface httpd-request-interface
  (export 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))

(define-structure httpd-request httpd-request-interface
  (open define-record-types    ;; define-record-discloser
	defrec-package         ;; define-record  
	scheme)
  (files (httpd request)))

(define-interface httpd-constants-interface
  (export server/version
	  server/protocol))

(define-structure httpd-constants httpd-constants-interface
  (open scheme)
  (files (httpd constants)))

(define-interface httpd-text-generation-interface
  (export time->http-date-string
	  begin-http-header
	  title-html))

(define-structure httpd-text-generation httpd-text-generation-interface
  (open formats
	httpd-reply-codes		; reply-code->text
	crlf-io
	httpd-constants
	scheme
	scsh)				; format-date
  (files (httpd text-generation)))


;; path-handlers

;;; httpd-basic-handlers

(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-request			; REQUEST record type, v0.9-request
	httpd-reply-codes		; reply codes
	httpd-text-generation		; begin-http-header
	httpd-error			; HTTP-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)))


;;; seval-handler

(define-interface seval-handler-interface
  (export seval-handler))

(define-structure seval-handler seval-handler-interface
  (open scsh		; syscalls & INDEX
	httpd-error
	httpd-request			; v0.9-request
	httpd-reply-codes
	httpd-text-generation		; begin-http-header
	httpd-logging			; http-log
	uri		; UNESCAPE-URI
	htmlout		; Formatted HTML output
	error-package	; ERROR
	pp		; Pretty-printer
	string-lib      ; STRING-SKIP
	rfc822
	toothless-eval	; EVAL-SAFELY
	handle		; IGNORE-ERROR
	parse-html-forms ; PARSE-HTML-FORM-QUERY
	threads         ; SLEEP
	scheme)
  (files (httpd seval)))



;;; info-gateway

(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
	htmlout
	httpd-request
	httpd-text-generation
	httpd-reply-codes
	httpd-error
	url
	uri
	scsh
	handle-fatal-error
	scheme)
  (files (httpd info-gateway)))


;;; rman-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-reply-codes
	httpd-request
	httpd-text-generation
	httpd-error
	conditions
	url
	uri
	htmlout
	httpd-basic-handlers
	handle-fatal-error
	scsh
	let-opt
	string-lib
	scheme)
  (files (httpd rman-gateway)))


;;; CGI Server

;;; Provides the server interface to CGI scripts.
(define-interface cgi-server-interface 
  (export cgi-default-bin-path
	  cgi-handler))

(define-structure cgi-server cgi-server-interface
  (open	string-lib
	rfc822
	crlf-io			; WRITE-CRLF
	uri
	url			; HTTP-URL record type
	httpd-constants
	httpd-logging
	httpd-request
	httpd-reply-codes
	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
	let-opt                 ; let-optionals
	scheme)
  (files (httpd cgi-server)))


;;; FTP server: ftpd
	
(define-interface ftpd-interface 
  (export ftpd
	  ftpd-inetd))

(define-structure ftpd ftpd-interface 
  (open scsh
	conditions handle signals
	structure-refs
	handle-fatal-error
	scheme
	threads threads-internal    ; last one to get CURRENT-THREAD
	locks
	thread-fluids               ; fork-thread
	fluids
	string-lib
	big-util
	defrec-package
	crlf-io
	ls
	let-opt
	receiving                   ; RECEIVE
	format-net)                 ; pretty print of internet-addresses
  (access big-scheme)
  (files ftpd))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; else: TOOTHLESS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; -*- 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)))))))