; RFC 959 ftp daemon

; Mike Sperber <sperber@informatik.uni-tuebingen.de>
; Copyright (c) 1998 Michael Sperber.

; It doesn't support the following desirable things:
;
; - Login by user; this requires crypt which scsh doesn't have
; - RESTART support
; - Banners from files on CWD
; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/


(define-record session
  control-input-port
  control-output-port
  (logged-in? #f)
  (authenticated? #f)
  (anonymous? #f)
  (root-directory #f)
  (current-directory "")
  (to-be-renamed #f)
  (reverse-replies '())
  (reply-code #f) ; the last one wins
  (type 'ascii)       ; PLEASE set this to bin 
  (data-socket #f)
  (passive-socket #f))

(define session (make-fluid #f))

(define (make-fluid-selector selector)
  (lambda () (selector (fluid session))))

(define (make-fluid-setter setter)
  (lambda (value)
    (setter (fluid session) value)))

	
(define session-control-input-port (make-fluid-selector session:control-input-port))
(define session-control-output-port (make-fluid-selector session:control-output-port))
(define session-logged-in? (make-fluid-selector session:logged-in?))
(define session-authenticated? (make-fluid-selector session:authenticated?))
(define session-anonymous? (make-fluid-selector session:anonymous?))
(define session-root-directory (make-fluid-selector session:root-directory))
(define session-current-directory (make-fluid-selector session:current-directory))
(define session-to-be-renamed (make-fluid-selector session:to-be-renamed))
(define session-reverse-replies (make-fluid-selector session:reverse-replies))
(define session-reply-code (make-fluid-selector session:reply-code))
(define session-type (make-fluid-selector session:type))
(define session-data-socket (make-fluid-selector session:data-socket)) 
(define session-passive-socket (make-fluid-selector session:passive-socket))

(define set-session-control-input-port 
  (make-fluid-setter set-session:control-input-port))
(define set-session-control-output-port 
  (make-fluid-setter set-session:control-output-port))
(define set-session-logged-in? (make-fluid-setter set-session:logged-in?))
(define set-session-authenticated? (make-fluid-setter set-session:authenticated?))
(define set-session-anonymous? (make-fluid-setter set-session:anonymous?))
(define set-session-root-directory (make-fluid-setter set-session:root-directory))
(define set-session-current-directory (make-fluid-setter set-session:current-directory))
(define set-session-to-be-renamed (make-fluid-setter set-session:to-be-renamed))
(define set-session-reverse-replies (make-fluid-setter set-session:reverse-replies))
(define set-session-reply-code (make-fluid-setter set-session:reply-code))
(define set-session-type (make-fluid-setter set-session:type))
(define set-session-data-socket (make-fluid-setter set-session:data-socket)) 
(define set-session-passive-socket (make-fluid-setter set-session:passive-socket))
	
(define (ftpd . maybe-port)
  (let ((port (optional maybe-port 21)))
    (bind-listen-accept-loop
     protocol-family/internet
     (lambda (socket address)
       
       (set-ftp-socket-options! socket)
       
       (spawn
	(lambda () 
	  (handle-connection (socket:inport socket) 
			     (socket:outport socket))
	  (call-with-current-continuation
	   (lambda (exit)
	   (with-errno-handler*
	    (lambda (errno packet)
	      (cond
	       ;; I dunno why SHUTDOWN-SOCKET can die this way, but it
	       ;; can and does
	       ((= errno errno/notconn)
		(exit 'fick-dich-ins-knie))))
	    (lambda ()
	      (shutdown-socket socket shutdown/sends+receives)
	      (close-socket socket))))))))
     
     port)))

(define (ftpd-inetd)
  (handle-connection (current-input-port)
		     (current-output-port)))

(define (set-ftp-socket-options! socket)
  ;; If the client closes the connection, we won't lose when we try to
  ;; close the socket by trying to flush the output buffer.
  (set-port-buffering (socket:outport socket) bufpol/none)

  (set-socket-option socket level/socket socket/oob-inline #t))


(define (handle-connection input-port output-port)
  (call-with-current-continuation
   (lambda (escape)
     (with-handler
      (lambda (condition more)
	(display condition (current-error-port))
	(escape 'fick-dich-ins-knie))
      (lambda ()
	(let-fluid session (make-session input-port output-port)
		   (lambda ()
		     (display-banner)
		     (handle-commands))))))))

(define (display-banner)
  (register-reply! 220
		   (string-append
		    "Scheme Untergrund ftp server ("
		    *ftpd-version*
		    ") ready.")))

(define-condition-type 'ftpd-quit '())
(define ftpd-quit? (condition-predicate 'ftpd-quit))

(define-condition-type 'ftpd-error '())
(define ftpd-error? (condition-predicate 'ftpd-error))


(define (handle-commands)
  (with-handler
   (lambda (condition more)
     ;; this in really only for ftpd-quit
     (write-replies)
     (more))
   (lambda ()
     (let loop ()
       (write-replies)
       (accept-command)
       (loop)))))

(define (accept-command)
  (let ((command-line (read-crlf-line-timeout (session-control-input-port)
					      #f
					      90000     ; timeout
					      500)))    ; max interval
    ;; (format #t "Command line: ~A~%" command-line)
     (cond ((eq? command-line 'timeout)
	    (register-reply! 
	     421
	     "Timeout (900 seconds): closing control connection.")
	    (signal 'ftpd-quit))
	   (else
	    (call-with-values
	     (lambda () (parse-command-line command-line))
	     (lambda (command arg)
	       (handle-command command arg)))))))

(define (handle-command command arg)
  (call-with-current-continuation
   (lambda (escape)
     (with-handler
      (lambda (condition more)
	(cond
	 ((error? condition)
	  (register-reply! 451
			   (format #f "Internal error: ~S"
				   (condition-stuff condition)))
	  (escape 'fick-dich-ins-knie))
	 ((ftpd-error? condition)
	  (escape 'fick-dich-ins-knie))
	 (else
	  (more))))
      (lambda ()
	(with-errno-handler*
	 (lambda (errno packet)
	   (register-reply! 451
			    (format #f "Unix error: ~A." (car packet)))
	   (escape 'fick-dich-ins-knie))
	 (lambda ()
	   (dispatch-command command arg))))))))

(define (dispatch-command command arg)
  (cond
   ((assoc command *command-alist*)
    => (lambda (pair)
	 ((cdr pair) arg)))
   (else
    (register-reply! 500
		     (string-append
		      (format #f "Unknown command: \"~A\"" command)
		      (if (string=? "" arg)
			  "."
			  (format #f " (argument(s) \"~A\")." arg)))))))


(define (handle-user name)
  (cond
   ((session-logged-in?)
    (register-reply! 230
		     "You are already logged in."))
   ((or (string=? "anonymous" name)
	(string=? "ftp" name))
    (handle-user-anonymous))
   (else
    (register-reply! 530
		     "Only anonymous logins allowed."))))

(define (handle-user-anonymous)
  (let ((ftp-info '(user-info "gasbichl")))

    '(set-gid (user-info:gid ftp-info))
    '(set-uid (user-info:uid ftp-info))

    (set-session-logged-in? #t)
    (set-session-authenticated? #t)
    (set-session-anonymous? #t)
    (set-session-root-directory "/afs/informatik.uni-tuebingen.de/data/ftp/")
    (set-session-current-directory "")

    (register-reply! 230 "Anonymous user logged in.")))

(define (handle-pass password)
  (cond
   ((not (session-logged-in?))
    (register-reply! 530 "You have not logged in yet."))
   ((session-anonymous?)
    (register-reply! 200 "Thank you."))
   (else
    (register-reply! 502 "This can't happen."))))

(define (handle-quit foo)
  (register-reply! 221 "Goodbye!  Au revoir!  Auf Wiedersehen!")
  (signal 'ftpd-quit))

(define (handle-syst foo)
  (register-reply! 215 "UNIX Type: L8"))

(define (handle-cwd path)
  (ensure-authenticated-login)
  (let ((current-directory (assemble-path path)))
    (with-errno-handler*
     (lambda (errno packet)
       (signal-error! 550
			(format #f "Can't change directory to \"~A\": ~A."
				path
				(car packet))))
     (lambda ()
       (with-cwd*
	(file-name-as-directory
	 (string-append (session-root-directory) current-directory))
	(lambda ()			; I hate gratuitous syntax
	  (set-session-current-directory current-directory)
	  (register-reply! 250
			   (format #f "Current directory changed to \"/~A\"."
				   current-directory))))))))

(define (handle-cdup foo)
  (handle-cwd ".."))

(define (handle-pwd foo)
  (ensure-authenticated-login)
  (register-reply! 257
		   (format #f "Current directory is \"/~A\"."
			   (session-current-directory))))


(define (make-file-action-handler error-format-string action)
  (lambda (path)
    (ensure-authenticated-login)
    (if (string=? "" path)
	(signal-error! 500 "No argument."))
    (let ((full-path (string-append (session-root-directory)
				    (assemble-path path))))
      (with-errno-handler*
       (lambda (errno packet)
	 (signal-error! 550
			(format #f error-format-string
				path (car packet))))
       (lambda ()
	 (action path full-path))))))

(define handle-dele
  (make-file-action-handler
   "Could not delete \"~A\": ~A."
   (lambda (path full-path)
     (delete-file full-path)
     (register-reply! 250 (format #f "Deleted \"~A\"." path)))))

(define handle-mdtm
  (make-file-action-handler
   "Could not get info on \"~A\": ~A."
   (lambda (path full-path)
     (let* ((info (file-info full-path))
	    (the-date (date (file-info:mtime info) 0)))
       (register-reply! 213
			(format-date "~Y~m~d~H~M~S" the-date))))))

(define handle-mkd
  (make-file-action-handler
   "Could not make directory \"~A\": ~A."
   (lambda (path full-path)
     (create-directory full-path #o755)
     (register-reply! 257
		      (format #f "Created directory \"~A\"." path)))))

(define handle-rmd
  (make-file-action-handler
   "Could not remove directory \"~A\": ~A."
   (lambda (path full-path)
     (delete-directory full-path)
     (register-reply! 250
		      (format #f "Deleted directory \"~A\"." path)))))


(define handle-rnfr
  (make-file-action-handler
   "Could not get info on file \"~A\": ~A."
   (lambda (path full-path)
     (file-info full-path)
     (register-reply! 350 "RNFR accepted.  Gimme a RNTO next.")
     (set-session-to-be-renamed full-path))))

(define (handle-rnto path)
  (ensure-authenticated-login)
  (if (not (session-to-be-renamed))
      (signal-error! 503 "Need RNFR before RNTO."))
  (if (string=? "" path)
      (signal-error! 500 "No argument."))
  (let ((full-path (string-append (session-root-directory)
				  (assemble-path path))))

    (if (file-exists? full-path)
	(signal-error!
	 550
	 (format #f "Rename failed---\"~A\" already exists or is protected."
		 path)))

    (with-errno-handler*
     (lambda (errno packet)
       (signal-error! 550
		      (format #f "Could not rename: ~A." path)))
     (lambda ()
       (rename-file full-path)
       (register-reply! 250 "File renamed.")
       (set-session-to-be-renamed #f)))))
  
(define handle-size
  (make-file-action-handler
   "Could not get info on file \"~A\": ~A."
   (lambda (path full-path)
     (let ((info (file-info full-path)))
       (if (not (eq? 'regular (file-info:type info)))
	   (signal-error! 550
			  (format #f "\"~A\" is not a regular file."
				  path)))
       (register-reply! 213 (number->string (file-info:size info)))))))


(define (handle-type arg)
  (cond
   ((string-ci=? "A" arg)
    (set-session-type 'ascii))
   ((string-ci=? "I" arg)
    (set-session-type 'image))
   ((string-ci=? "L8" arg)
    (set-session-type 'image))
   (else
    (signal-error! 504
		   (format #f "Unknown TYPE: ~A." arg))))

  (register-reply! 200
		   (format #f "TYPE is now ~A."
			   (case (session-type)
			     ((ascii) "ASCII")
			     ((image) "8-bit binary")
			     (else "somethin' weird, man")))))

(define (handle-mode arg)
  (cond
   ((string=? "" arg)
    (register-reply! 500
		     "No arguments.  Not to worry---I'd ignore them anyway."))
   ((string-ci=? "S" arg)
    (register-reply! 200 "Using stream mode to transfer files."))
   (else
    (register-reply! 504 (format #f "Mode \"~A\" is not supported."
				 arg)))))

(define (handle-stru arg)
  (cond
   ((string=? "" arg)
    (register-reply! 500
		     "No arguments.  Not to worry---I'd ignore them anyway."))
   ((string-ci=? "F" arg)
    (register-reply! 200 "Using file structure to transfer files."))
   (else
    (register-reply! 504
		     (format #f "File structure \"~A\" is not supported."
			     arg)))))

(define (handle-noop arg)
  (register-reply! 200 "Done nothing, but successfully."))

(define *port-arg-regexp*
  (make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))

(define (parse-port-arg string)
  (cond
   ((regexp-exec *port-arg-regexp* string)
    => (lambda (match)
	 (let ((components
		(map (lambda (match-index)
		       (string->number
			(match:substring match match-index)))
		     '(1 2 3 4 5 6))))
	   (if (any? (lambda (component)
		       (> component 255))
		     components)
	       (signal-error! 501
			      "Invalid arguments to PORT."))
	   (apply
	    (lambda (a1 a2 a3 a4 p1 p2)
	      (values (+ (arithmetic-shift a1 24)
			 (arithmetic-shift a2 16)
			 (arithmetic-shift a3 8)
			 a4)
		      (+ (arithmetic-shift p1 8)
			 p2)))
	    components))))
   (else
    (signal-error! 500
		   "Syntax error in argument to PORT."))))


(define (handle-port stuff)
  (ensure-authenticated-login)
  (maybe-close-data-connection)
  (call-with-values
   (lambda () (parse-port-arg stuff))
   (lambda (address port)
     (let ((socket (create-socket protocol-family/internet
				  socket-type/stream)))

       (set-socket-option socket level/socket socket/reuse-address #t)

       (connect-socket socket
		       (internet-address->socket-address
			address port))
       
       (set-session-data-socket socket)

       (register-reply! 200
			(format #f "Connected to ~A, port ~A."
				(format-internet-host-address address)
				port))))))


(define (handle-pasv stuff)
  (ensure-authenticated-login)
  (maybe-close-data-connection)
  (let ((socket (create-socket protocol-family/internet
			       socket-type/stream)))
    
    (set-socket-option socket level/socket socket/reuse-address #t)

    ;; kludge
    (bind-socket socket
		 (internet-address->socket-address (this-host-address)
						   0))
    (listen-socket socket 1)

    (let ((address (socket-local-address socket)))

      (call-with-values
       (lambda () (socket-address->internet-address address))
       (lambda (host-address port)

	 (set-session-passive-socket socket)

	 (register-reply! 227
			  (format #f "Passive mode OK (~A,~A)"
				  (format-internet-host-address host-address ",")
				  (format-port port))))))))

; This doesn't look right.  But I can't look into the socket of the
; control connection if we're running under inetd---there's no way to
; coerce a port to a socket as there is in C.

(define (this-host-address)
  (car (host-info:addresses (host-info (system-name)))))

(define (format-internet-host-address address . maybe-separator)
  (let ((separator (optional maybe-separator ".")))
    (apply (lambda (b1 b2 b3 b4)
	     (string-append
	      b1 separator b2 separator
	      b3 separator b4))
	   (map number->string (internet-host-address-to-bytes address)))))
    
(define (format-port port)
  (string-append
   (number->string (bitwise-and (arithmetic-shift port -8) 255))
   ","
   (number->string (bitwise-and port 255))))

(define (handle-nlst arg)
  (handle-listing arg '()))

(define (handle-list arg)
  (handle-listing arg '(long)))
  
(define (handle-listing arg preset-flags)
  (ensure-authenticated-login)
  (with-data-connection
   (lambda ()
     (let ((args (split-arguments arg)))
       (call-with-values
	(lambda ()
	  (partition-list
	   (lambda (arg)
	     (and (not (string=? "" arg))
		  (char=? #\- (string-ref arg 0))))
	   args))
	(lambda (flag-args rest-args)

	  (if (and (not (null? rest-args))
		   (not (null? (cdr rest-args))))
	      (signal-error! 501 "More than one path argument."))

	  (let ((path (if (null? rest-args)
			  ""
			  (car rest-args)))
		(flags (arguments->ls-flags flag-args)))

	    (if (not flags)
		(signal-error! 501 "Invalid flag(s)."))

	    (generate-listing path (append preset-flags flags)))))))))

; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
; ENSURE-DATA-CONNECTION.

(define (generate-listing path flags)
  (let ((full-path (string-append (session-root-directory)
				  (assemble-path path))))
    (with-errno-handler*
     (lambda (errno packet)
       (signal-error! 451
		      (format #f "Can't access directory at ~A: ~A."
			      path
			      (car packet))))
     (lambda ()
       (with-cwd*
	(file-name-directory full-path)
	(lambda ()
	  (let ((nondir (file-name-nondirectory full-path)))
	    (ls flags
		(list
		 ;; work around OLIN BUG
		 (if (string=? nondir "")
		     "."
		     nondir))
		(socket:outport (session-data-socket))))))))))

(define (handle-abor foo)
  (maybe-close-data-connection)
  (register-reply! 226 "Closing data connection."))

(define (handle-retr path)
  (ensure-authenticated-login)
  (let ((full-path (string-append (session-root-directory)
				  (assemble-path path))))
    (with-fatal-error-handler*		; CALL-WITH-INPUT-FILE doesn't go through ERRNO
     (lambda (condition more)
       (signal-error! 550
		      (format #f "Can't open \"~A\" for reading."
			      path)))
     (lambda ()
       (let ((info (file-info full-path)))
	 (if (not (eq? 'regular (file-info:type info)))
	     (signal-error! 450
			    (format #f "\"~A\" is not a regular file."
				    path)))
	 (call-with-input-file full-path
	   (lambda (file-port)
	     (with-data-connection
	      (lambda ()
		(case (session-type)
		  ((image)
		   (copy-port->port-binary
		    file-port
		    (socket:outport (session-data-socket))))
		  ((ascii)
		   (copy-port->port-ascii
		    file-port
		    (socket:outport (session-data-socket))))))))))))))

(define (handle-stor path)
  (ensure-authenticated-login)
  (let ((full-path (string-append (session-root-directory)
				  (assemble-path path))))
    (with-fatal-error-handler*
     (lambda (condition more)
       (signal-error! 550
		      (format #f "Can't open \"~A\" for writing."
			      path)))
     (lambda ()
       (call-with-output-file full-path
	 (lambda (file-port)
	   (with-data-connection
	    (lambda ()
	      (case (session-type)
		((image)
		 (copy-port->port-binary
		  (socket:inport (session-data-socket))
		  file-port))
		((ascii)
		 (copy-ascii-port->port
		  (socket:inport (session-data-socket))
		  file-port)))))))))))
  
(define (assemble-path path)
  (let* ((interim-path
	  (if (not (file-name-rooted? path))
	      (string-append (file-name-as-directory 
			      (session-current-directory))
			     path)
	      path))
	 (complete-path (if (file-name-rooted? interim-path)
			    (file-name-sans-rooted interim-path)
			    interim-path)))
    (cond
     ((normalize-path complete-path)
      => (lambda (assembled-path) assembled-path))
     (else
      (signal-error! 501 "Invalid pathname")))))

(define (ensure-authenticated-login)
  (if (or (not (session-logged-in?))
	  (not (session-authenticated?)))
      (signal-error! 530 "You're not logged in yet.")))

(define (with-data-connection thunk)
  (dynamic-wind ensure-data-connection
		thunk
		maybe-close-data-connection))
  
(define *window-size* 51200)

(define (ensure-data-connection)
  (if (and (not (session-data-socket)) 
	   (not (session-passive-socket)))
      (signal-error! 425 "No data connection."))

  (if (session-passive-socket)
      (call-with-values
       (lambda () (accept-connection (session-passive-socket)))
       (lambda (socket socket-address)
	 (set-session-data-socket socket))))

  (register-reply! 150 "Opening data connection.")
  (write-replies)

  (set-socket-option (session-data-socket) level/socket
		     socket/send-buffer *window-size*)
  (set-socket-option (session-data-socket) level/socket
		     socket/receive-buffer *window-size*))

(define (maybe-close-data-connection)
  (if (or (session-data-socket) (session-passive-socket))
      (close-data-connection)))

(define (close-data-connection)
  (if (session-data-socket)
      (close-socket (session-data-socket)))
  (if (session-passive-socket)
      (close-socket (session-passive-socket)))
  (register-reply! 226 "Closing data connection.")
  (set-session-data-socket #f)
  (set-session-passive-socket #f))

(define *command-alist*
  (list
   (cons "NOOP" handle-noop)
   (cons "USER" handle-user)
   (cons "PASS" handle-pass)
   (cons "QUIT" handle-quit)
   (cons "SYST" handle-syst)
   (cons "CWD" handle-cwd)
   (cons "PWD" handle-pwd)
   (cons "CDUP" handle-cdup)
   (cons "DELE" handle-dele)
   (cons "MDTM" handle-mdtm)
   (cons "MKD" handle-mkd)
   (cons "RMD" handle-rmd)
   (cons "RNFR" handle-rnfr)
   (cons "RNTO" handle-rnto)
   (cons "SIZE" handle-size)
   (cons "TYPE" handle-type)
   (cons "MODE" handle-mode)
   (cons "STRU" handle-stru)
   (cons "PORT" handle-port)
   (cons "PASV" handle-pasv)
   (cons "NLST" handle-nlst)
   (cons "LIST" handle-list)
   (cons "RETR" handle-retr)
   (cons "STOR" handle-stor)
   (cons "ABOR" handle-abor)))

(define (parse-command-line line)
  (if (eof-object? line) ; Netscape does this
      (values "QUIT" "")
      (let* ((line (trim-spaces line))
	     (split-position (string-index line #\space)))
	(if split-position
	    (values (upcase-string (substring line 0 split-position))
		    (trim-spaces (substring line
					    (+ 1 split-position)
					    (string-length line))))
	    (values (upcase-string line) "")))))

; Path names

; This removes all internal ..'s from a path.
; NORMALIZE-PATH returns #f if PATH points to a parent directory.

(define (normalize-path path)
  (let loop ((components (split-file-name (simplify-file-name path)))
	     (reverse-result '()))
    (cond
     ((null? components)
      (path-list->file-name (reverse reverse-result)))
     ((null? (cdr components))
      (if (string=? ".." (car components))
	  #f
	  (path-list->file-name
	   (reverse (cons (car components) reverse-result)))))
     ((string=? ".." (cadr components))
      (loop (cddr components) reverse-result))
     (else
      (loop (cdr components) (cons (car components) reverse-result))))))

(define (file-name-rooted? file-name)
  (and (not (string=? "" file-name))
       (char=? #\/ (string-ref file-name 0))))

(define (file-name-sans-rooted file-name)
  (substring file-name 1 (string-length file-name)))

(define split-arguments
  (infix-splitter (make-regexp " +")))

; Reply handling

; Replies must be synchronous with requests and actions.  Therefore,
; they are queued on generation via REGISTER-REPLY!.  The messages are
; printed via WRITE-REPLIES.  For the nature of the replies, see RFC
; 959.


(define (write-replies)
  (if (not (null? (session-reverse-replies)))
      (let loop ((messages (reverse (session-reverse-replies))))
	(if (null? (cdr messages))
	    (write-final-reply (car messages))
	    (begin
	      (write-nonfinal-reply (car messages))
	      (loop (cdr messages))))))
  (set-session-reverse-replies '()))

(define (write-final-reply line)
  (format (session-control-output-port) "~D ~A" (session-reply-code) line)
  ;; (format #t "Reply: ~D ~A~%" (session-reply-code) line)
  (write-crlf (session-control-output-port)))

(define (write-nonfinal-reply line)
  (format (session-control-output-port) "~D-~A" (session-reply-code) line)
  ;; (format #t "Reply: ~D-~A~%" (session-reply-code) line)
  (write-crlf (session-control-output-port)))

(define (signal-error! code message)
  (register-reply! code message)
  (signal 'ftpd-error))

(define (register-reply! code message)
  (set-session-reverse-replies
	(cons message (session-reverse-replies)))
  (set-session-reply-code code))

; Version

(define *ftpd-version* "$Revision: 1.8 $")

(define (copy-port->port-binary input-port output-port)
  (let ((buffer (make-string *window-size*)))
    (let loop ()
      (cond
       ((read-string! buffer input-port)
	=> (lambda (length)
	     (write-string buffer output-port 0 length)
	     (loop))))))
  (force-output output-port))

(define (copy-port->port-ascii input-port output-port)
  (let loop ()
    (let ((line (read-line input-port 'concat)))
      (if (not (eof-object? line))
	  (let ((length (string-length line)))
	    (cond
	     ((zero? length)
	      'fick-dich-ins-knie)
	     ((char=? #\newline (string-ref line (- length 1)))
	      (write-string line output-port 0 (- length 1))
	      (write-crlf output-port))
	     (else
	      (write-string line output-port)))
	    (loop)))))
  (force-output output-port))

(define (copy-ascii-port->port input-port output-port)
  (let loop ()
    (let* ((line (read-crlf-line input-port
				 #f
				 90000    ; timeout
				 500))    ; max interval
	   (length (string-length line)))
      (if (not (eof-object? line))
	  (begin
	    (write-string line output-port 0 length)
	    (newline output-port)
	    (loop)))))
  (force-output output-port))

; Utilities

(define (optional maybe-arg default-exp)
  (cond
   ((null? maybe-arg) default-exp)
   ((null? (cdr maybe-arg)) (car maybe-arg))
   (else (error "too many optional arguments" maybe-arg))))

; Stuff from Big Scheme
; We can't open BIG-SCHEME because we use virgin SIGNALS.  Sigh.

(define any? (structure-ref big-scheme any?))
(define partition-list (structure-ref big-scheme partition-list))