;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:ZL; Fonts:(MEDFNT MEDFNB) -*-

;;;LOG-SERVER.LISP

;;;This is a relatively simple example of implementing a
;;;custom, uni-directional TCP server.

;;;The server is called 'LOG-SERVER'; it waits for a connection, sends
;;;a message back to the client, listens for a response, and logs the
;;;message in a log file.

;;;To run this example, compile it; load it on any two Lambdas
;;;connected via TCP; run (START-LOG-SERVER) on the server host;
;;;and run from the client host, e.g.,

#|
   (LOG-CLIENT :SEND)		    
   (LOG-CLIENT :SEND "HI, THIS IS A MESSAGE")
   (LOG-CLIENT :SEND "HI, THIS IS A MESSAGE" 'HOST)
   (LOG-CLIENT :RECEIVE)
|#
;;;...where <HOST> is the name of the server host.  After the client
;;;sends, the log server should log the message it received from the
;;;client; if receiving, the client should return with the hello
;;;message it got from the server.

;;;Messages are logged in a log file.  The log file is kept by default
;;;on the "SYS HOST"; customize DEFAULT-LOG-SERVER-HOST as desired.

;;;Run (LOG-STATUS) to see the log.

(defvar *log-server-logging-flag* t
  "If NIL, disables message logging.")

(defconst *logfile*  "LOG-SERVER;LOG-SERVER.LOG"
  "Log file filename.")

(defun default-log-server-host()
  (si:parse-host
    (or (si:get-site-option :sys-host)
	(send (fs:translated-pathname "SYS:SITE;") :host)
	si:associated-machine
	si:local-host)))

(defvar *log-server-host* (default-log-server-host))

(defun log-status (&optional host)
  "View LOG-SERVER log file on HOST."
  (setq host (or host *log-server-host*))
  (viewf (logfile-pathname host)))

(defmacro log-message (format-str &rest args)
  "If *LOG-SERVER-LOGGING-FLAG* on, log message according to 
FORMAT-STR and ARGS as per FORMAT."
  `(when *log-server-logging-flag*
     (format t "~&*** ")
     (time:print-current-time)
     (format t " | ")
     (format t ,format-str ,@args)
     (format t "~&")))

(defun logfile-pathname (&optional (host *log-server-host*))
  (fs:merge-pathnames *logfile* (si:parse-host host)))

(defun clear-log (&optional (host *log-server-host*))
  "Initialize log file."
  (setq host (or host (default-log-server-host)))
  (fs:create-directory (logfile-pathname host))
  (with-open-file (log (logfile-pathname host) :direction :output)
    (let ((standard-output log))
      (log-message "Log file initialized"))))

(defmacro adding-to-log (&body body)
  `(with-open-file (log (logfile-pathname)
			:direction :output
			:if-exists :append)
     (let ((standard-output log))
       . ,body)))

;;;Global definitions for TCP.

;;;Define TCP/IP port number. I arbitrarily chose a port number
;;;above the reserved" range, 0-255.

(tcpa:defsym ipport-log-server 258.)

(defconst *log-message-buffer-size* 2048.
  "Max size for string/packet buffers.")

(defun log-server-pathname (&optional (host *log-server-host*))
  "Return a pathname to address LOG-SERVER."
  (pathname
    (format nil "TCP-HOST:~A#LOG-SERVER"
	    (send (si:parse-host host) :name))))

(defun say-hello (stream &optional (who-am-i fs:user-id))
  "Print a hello message to stream;
WHO-AM-I should be a string, defaults to the logged-in user id."
  (format stream
	  "~&Hello from ~s running on ~a at "
	  who-am-i
	  (send si:local-host :string-for-printing))
  (time:print-current-time stream)
  (send stream :force-output))

(defvar *log-default-timeout* 10.
  "Number of seconds to wait for response from LOG-SERVER")

(defun wait-and-listen(stream &optional (timeout *log-default-timeout*))
  (let* ((sleep-a-second 60.)
	 got-it)
    (dotimes (j timeout)
      (when (setq got-it (send stream :listen))
	(return-from wait-and-listen got-it))
      (process-sleep sleep-a-second "listening"))))

(defun get-buffer-string(stream)
  "Returns pending message from STREAM (presumably a TCP stream),
  if available.
Returns two values, the string and its length."
  (declare (values string length))
  (when (send stream :listen)
    (let ((buff(make-string *log-message-buffer-size*)))
      (multiple-value-bind (len gotit)
	  (send stream :string-in nil buff)
	(when gotit
	  (send stream :advance-input-buffer)
	  (values (substring buff 0  len)
		  len))))))

;;;Server side.

;;;The server sends a hello and waits for a message back.  

(defvar *log-server-stream* nil
  "Most recently opened LOG-SERVER stream (server side)")

(defvar *log-server-timeout* 20.)

(defun server-listen (stream)
  "Server routine to get message from client."
  ;;IF NO msg from client
  (if (null (wait-and-listen stream *log-server-timeout*))
      (adding-to-log
	(log-message "LOG-SERVER :listen failed from ~s" stream))
    (let ((msg (get-buffer-string stream)))
      (if msg
	  (adding-to-log
	   (log-message "Got '~a' from LOG-CLIENT" msg))
	(adding-to-log
	  (log-message "Got back nothing from LOG-CLIENT")))
      msg)))

(defun log-server-top-level (stream)
  "Top level function established by TCP to deal
with connections to LOG-SERVER."
  (let ((user-id 'LOG-SERVER))
    (setq *log-server-stream* stream)
    (typecase stream
      (tcp:tcp-buffered-stream
       (say-hello stream 'log-server)
       (server-listen stream))
      (t (adding-to-log
	   (log-message "Invalid stream from client: ~s" stream))))))

(defvar *log-service*)

(tcpa:define-network-service *log-service* :log-server :TCP "Message Log Server"
  :listen-port (tcpa:sym ipport-log-server)
  :toplevel-function 'log-server-top-level
  ;;This is NIL because most hosts don't want to be LOG servers:
  :auto-enable? NIL)

(defun enable-log-server (&key (log-server-host *log-server-host*) (clear-log t))
  "User interface to start up the LOG-SERVER."
  ;;Let caller define the log file host
  (setq *log-server-host* (si:parse-host log-server-host))
  (catch-error
    (if clear-log (clear-log)))
  (format t "~&Starting LOG-SERVER...")
  (tcpa:enable-one-network-service *log-service*))

(defun disable-log-server ()
  (tcpa:disable-one-network-service *log-service*))

	
;;;Client side.

(defvar *log-client-stream* nil
  "Most recently opened LOG-SERVER stream (client side)")

(defvar *log-client-timeout* *log-default-timeout*)

(defun log-client-receive (stream)
  "Client routine to get message from server."
  (let ((msg (get-buffer-string stream)))
    (if (null msg) (ferror nil "Null message from LOG-SERVER"))
    (format t "LOG-CLIENT got back '~a' " msg)
    (send stream :advance-input-buffer)))

(defun log-client-send (stream msg)
  "Client routine to send user's message to server."
  (send stream :string-out msg 0 (string-length msg))
  (send stream :force-output))

(defun log-client (&optional (mode :send) message (host *log-server-host*))
  "Send a message to the LOG-SERVER on HOST.
HOST defaults per *log-server-host*; normally,
  this is the value returned by (default-log-server-host).
MODE can be :SEND (to send a message to the server
  and log it) or :RECEIVE (to get a hello message
 from the server). Can't do both."
  (let ((pathname (log-server-pathname host))
	(*log-server-host* host))
    (with-open-file
      (stream pathname :auto-force-output t)
      (setq *log-client-stream* stream)
      (case mode
	(:receive
	 (if (null (wait-and-listen stream))
	     (ferror nil "No response from LOG-SERVER at ~a" pathname))
	 (log-client-receive stream))
	(:send
	 (format t "~&Sending message to LOG-SERVER at ~a" pathname)
	 (if message
	     (log-client-send stream message)
	   (say-hello stream 'log-client)))
	(t (ferror nil "No LOG-CLIENT mode of ~s" mode)))
      )))