(require "ss.dll")
(require "exn.scm")

;;; The Pocket Scheme REPL server.
;;; Demonstrates 1) writing a TCP/IP server; 2) defining soft ports; 3) handling exceptions.
;;;
;;; To connect to the server from a client, telnet ADDRESS 666, where ADDRESS is the 
;;; network address of the NIC in the H/PC.
;;; If the H/PC is docked and the workstation runs Windows NT Remote Access Services, 
;;; you can access the H/PC from the workstation only via the address that RAS gave it locally -
;;; typically 192.168.55.100 or 101.
;;; Well, that was true five years ago; doesn't seem to be the case any more.
;;; You'll need a NIC on the H/PC.
;;;
;;; At the CE> prompt in telnet, type any expression to have Pocket Scheme evaluate that
;;; expression on the H/PC.
;;; To quit, simply hang up, or type ,bye.
;;; Typing ,kill will hang up the Scheme server as well;
;;; otherwise, the server continues to listen for new clients.
;;; Only one client may use the server at a time.
;;;
;;; 6-Oct-1999 goetter
;;;  renamed socket:* routines to tcp:*
;;; 27-Oct-1999 goetter
;;;  replaced require-so with require-dll
;;; 9-May-2005 goetter
;;;  ported to 1.2


;;; Extend exn:io:get-port to include ss.dll's usage

(define (exn:io:get-port x)
 (let retry ((o (exn:get-object x)))
  (cond ((null? o) #f)
        ((or (input-port? o) 
	     (output-port? o)
	     (raw-input-source? o) 
	     (raw-output-sink? o)
	     (tcp:listener? o)
	     (tcp:connection? o)) o)
        ((pair? o) (retry (car o)))
        (else #f) )))

(define-exn exn:timeout)


;;; Input handler for a "telnet" stream.  Cooks I/O from the binary socket stream
;;; and provides rudimentary line editing.  Not real telnet of course - just something
;;; that'd pass for a q&d mud.
;;; "Outport" is the char port to which to echo typed characters.
;;; Similar to (COOK-INPUT-SOURCE  source #f 'latin-1 'crlf-newline)
;;; with additional options for echo and backspace handling

(define (make-telnet-in-handler source outport)
 (let ((charqueue '()))
  (letrec ((drop-q 
	    (lambda ()
	      (if (not (null? charqueue)) (set! charqueue (cdr charqueue)))))

	   (head-of-q 
	    (lambda ()
	      (if (null? charqueue)
		  (read-octet source) ;; for EOF
		  (car charqueue))))

	   (echo 
	    (lambda (ch)
	      (display ch outport)
	      (force-output outport)))

	   (reload 
	    (lambda ()
	      (set! charqueue
		    (let loop ((l '()))
		      (let ((o (read-octet source)))
			(if (eof-object? o)
			    (reverse l)
			    (case o
			      ((8) 
			       (echo (unicode->char o))
			       (loop (if (null? l) l (cdr l))))
			      ((10) (loop l))
			      ((13) 
			       (echo #\newline)
			       (reverse (cons #\newline l)))
			      (else
			       (let ((ch (unicode->char o)))
				 (echo ch)
				 (loop (cons ch l)))))))))
	      (head-of-q)))

           (peekc 
	    (lambda ()
	      (if (null? charqueue) (reload) (head-of-q)))) )


   ;; A message handler for an input port.
   (lambda (msg . parm)
    (case msg
     ((peek-char)
      (peekc))
     ((read-char)
      (let ((ch (peekc)))
	(drop-q)
	ch))
     ((char-ready?)
      (cond
       ((not (null? charqueue)) #t)
       (else (data-ready? port))))
     ((close-port)) )))))
            

;;; Output handler, cooking LF to CRLF.
;;; Equivalent to (COOK-OUTPUT-SINK sink 'crlf-newline 'latin-1)

(define (make-telnet-out-handler sink)
 ;; A message handler for an output port.
 (lambda (msg . parm)
  (case msg
   ((write-char)
    (let ((ch (char->unicode (car parm))))
     (if (eq? ch 10) (write-octet 13 sink))
     (write-octet ch sink))) ; this will abend on non Latin-1 data
   ((force-output)
    (force-output sink))
   ((close-port)) )))


;;; The scsh bind-listen-accept-loop idiom.

;;; This version allows proc to escape out of and into the continuation 
;;; w/o disturbing the listening socket.

(define (bind-listen-accept-loop proc port)
 (let ((s (tcp:listen-server port)))
   (with-handlers 
    (
     ((lambda (x) #t) ; any exception
      (lambda (x) 
	(display "Received exception, shutting down server. ")
	(newline)
	;; GC isn't sufficiently precise to catch this in time.
	;;$ BUGBUG dig into this for 1.3
	(tcp:close-listener s)
	#t))
     )

    (let loop ()
      (proc (tcp:accept-connection s)) 
      (loop)))))


(define (servtest port)
 (call-with-current-continuation 
  (lambda (k)
    (display "Listening...") 
    (newline)
    (bind-listen-accept-loop 
     (lambda (a)
       (let ((original-out #f)
	     (source (tcp:connection-input a))
	     (sink (tcp:connection-output a)))
	 (display "Accepted connection.")
	 (newline)
	 ;; We'll get tcp:timeout exceptions every so often
	 (display "Timeout is ")
	 (display (tcp:timeout-seconds a))
	 (display " seconds.")
	 (newline)
	 (dynamic-wind
	     (lambda ()
	       (set! original-out (current-output-port))
	       (current-output-port (make-output-port (make-telnet-out-handler sink))))
	     (lambda () 
	       (s2test-run-repl a
				(make-input-port 
				 (make-telnet-in-handler 
				  source
				  (current-output-port))) k))
	     (lambda ()
	       (current-output-port original-out)))
	 (tcp:close-connection a)
	 (display "Ended connection.")
	 (newline) )) 
     port) )))


;;; s2test-run-repl runs a Scheme R-E-P-L.  It reads the expression to evaluate from
;;; a specified port, printing to whatever port is the output default.
;;; "abase" is the object atop which the port was built

(define (s2test-run-repl abase a k)
 (if (call-with-current-continuation 
      (lambda (kResume)
	(with-handlers 
	 (
	  ;; Catch a break sent while a user is connected.
	  ((lambda (x) (exn:break? x))
	   (lambda (x) 
	     (display "Administrator interrupt.")
	     (newline) 
	     (force-output)
	     (k #t)))

	  ;; Error on the connection
	  ((lambda (x) (and (exn:io? x)
			    (let ((o (exn:io:get-port x))) 
			      (or (eq? o a) (eq? o abase)))))
	   (lambda (x) 
	     (display "Connection to peer dropped." (current-error-port)) 
	     (newline (current-error-port)) 
	     (kResume #f))) 

	  ;; By default, connections time out.
	  ;; Print a rude message and continue.
	  ((lambda (x) (exn:timeout? x))
	   (lambda (x)
	     (display "The server yawns impatiently.")
	     (newline)
	     #t))

	  ;; Default exception handler
	  ((lambda (x) #t)
	   (lambda (x) 
	     (display "Error: ") 
	     (display (if (exn? x) (cdr x) x)) 
	     (newline) 
	     #t))
	  )

	 (let loop ()
	   (display "CE> ") 
	   (force-output)
	   (let ((r (read a)))
	     (if (not (eof-object? r))
		 (begin
		   (if (and (pair? r) (eq? (car r) 'unquote) (pair? (cdr r)))
		       (case (cadr r)
			 ((bye) (kResume #f))
			 ((kill) (k #f))))
		   (let ((res (eval r)))
		     (if (not (void-object? res))
			 (begin
			   (write res)
			   (newline))))
		   (write r (current-error-port)) 
		   (newline (current-error-port)) 
		   (loop))))))))

     (s2test-run-repl abase a k)
     #t))


;; e z 2 type
(define (go) (servtest 666))