sunet/modules.scm

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