sunet/scheme/packages.scm

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

(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 httpd-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 
	scsh-utilities 
	let-opt 
	srfi-13
	receiving 
	uri)
  (files (lib parse-forms)))

(define-structure htmlout htmlout-interface
  (open scheme-with-scsh
	scsh-utilities
	srfi-13
	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)
	scsh-utilities	; index
	srfi-13
	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
	srfi-13
	let-opt
	receiving
	ascii
	srfi-14
	bitwise
	field-reader-package)
  (files (lib uri)))

(define-structure url url-interface
  (open scheme-with-scsh
	scsh-utilities
	define-record-types
	receiving
	srfi-13
	srfi-14
	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
	srfi-13
	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
	srfi-13
	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
	big-scheme 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
	srfi-13
	dns
	let-opt				; :optional
	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 big-util (any? partition-list))
	crlf-io
	ls
	dns
	sunet-version
	sunet-utilities
	receiving                   ; RECEIVE
	format-net)                 ; pretty print of internet-addresses
  (files (ftpd ftpd)))

;; Web server

(define-structure httpd-core httpd-core-interface
  (open scheme-with-scsh
	thread-fluids			; fork-thread
	receiving			; receive
	crlf-io				; write-crlf, read-crlf-line
	rfc822				; read-rfc822-headers
	srfi-14				; 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
	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
	srfi-1)				; find
  (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
	big-scheme
	httpd-responses
	httpd-requests
	httpd-error
	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				; make-lock obtain-lock release-lock
	receiving			; receive
	uri				; uri-path-list->path
	url				; http-url-path
	httpd-requests			; request record
	formats				; format
	format-net			; format-internet-host-address
	srfi-13				; string-join, string-trim
	rfc822				; get-header
	sunet-utilities			; on-interrupt
	threads				; spawn
	dns				; dns-lookup-ip
	defrec-package			; define-record
	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
	srfi-9
	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
	srfi-1				; FOLD-RIGHT
	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
	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				; Pretty-printer
	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
	big-scheme
	srfi-13
	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
	srfi-13)
  (files (httpd rman-gateway)))

(define-structure httpd-cgi-handlers httpd-cgi-handlers-interface
  (open	scheme-with-scsh
	srfi-13
	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
	scsh-utilities		; INDEX
	formats			; format
	format-net              ; FORMAT-INTERNET-HOST-ADDRESS
	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)))))))