(in-package "IPC")

;;; File: server.lisp
;;; John:IPSI:Feb 9, 1996
;;;           update for KPML 1.0; August 1996.

;;; ----------------------------------------------------------------------
;;; BASIC (VERY) SERVER FUNCTIONALITY FOR USE WITH KPML.
;;; (Adapted from Allegro ACL4.2 release: code/ipc.cl)
;;; ----------------------------------------------------------------------
;;;
;;; Starting a KPML server is done by issuing a:
;;;
;;;  (kpml::start-kpml-server)
;;;
;;; this establishes a connection to a port, the host and the port number
;;; are left in the file
;;;
;;;       kpml::*com-file* (default: kpml::*default-com-file*, which
;;;
;;; by default is the file:  <user-home-directory>/KpmlCom.tmp
;;; Starting a KPML client from Lisp (see file: client.lisp)
;;; can then be done with the call
;;;
;;;  (common-lisp-user::start-kpml-client)
;;;
;;; this returns a stream to the port identified in the kpml::*com-file*. 
;;; Information can then be sent using ipc::send-to-socket; this function
;;; returns the value returned from the server. More usefully, 
;;; SPLs can be sent to KPML with the function call:
;;;
;;;   (kpml::server-say-string <SPL> stream).
;;;
;;; For more complex and neat interaction, see the KPML 1.0 documentation.
;;; ----------------------------------------------------------------------

(eval-when (compile load)
  (unless (find-package "KPML")(make-package "KPML")))

;;; The following set of function calls provide the foundation
;;; for the socket communication with the KPML Lisp process
;;; described above. 
;;; 
;;;   (ipc::set-socket "<socket-name>")
;;;   (ipc::start-lisp-listener-daemon :startup-stream-process
;;;           #'ipc::kpml-server-startup)
;;;
;;; The communication will close when a :stop comes over. 
;;;
;;; A client side from Lisp can secure access to the socket
;;; by issuing an (ipc::open-network-stream :socket-file "<socket-name">).
;;; It can then use the function ipc::send-to-socket
;;; defined below. Once stopped, the daemon needs to be killed
;;; before re-use, (ipc::kill-lisp-listener-daemon).
;;; Both named sockets and host and port numbers can be used:
;;; for host/ports simply omit the set-socket call above to make
;;; sure that ipc::*unix-domain* is nil. Then issue a
;;; (ipc::open-network-stream :host "..." :port nnn) to get 
;;; a stream to the port.
;;;

(defvar *kpml-log-stream* nil)
(defvar *kpml-server-protocol* nil "Set if logging desired")
(defvar kpml::*default-com-file* (pathname 
			    (merge-pathnames
			     "KpmlCom.tmp"
			     (user-homedir-pathname))))
(defvar kpml::*com-file* kpml::*default-com-file*)
(defvar kpml::*kpml-log-file* "/tmp/kpml-log")
(defvar kpml::*gen-strings* "")

;;; ----------------------------------------------------------------------
;;; Adapted from Allegro ACL4.2 release: code/ipc.cl
;;; But the password stuff has been taken out as it was
;;; blocking things somehow.

(defun KPML-SERVER-STARTUP 
  (stream 
   &key (function 'kpml-server-processor)
   listen-sockaddr fd
   &allow-other-keys)
  (declare (ignore listen-sockaddr fd))
  (format t "~%;;; KPML server connection established...")
  (process-run-function "KPML-SERVER" function stream))


(defun SET-SOCKET (socket-name)
  (setf *socket-pathname* socket-name)
  (setf *unix-domain* T)
  )

(defun SET-COM-FILE (&optional (hostname (short-site-name)))
  (format t "~%;;; Setting IPC details for port: ~A" *inet-port-used*)
  (with-open-file (s kpml::*com-file*
		   :direction :output
		   :if-not-exists :create
		   :if-exists :supersede)
    (format s "~A#~A" *inet-port-used* hostname )))

;;; ----------------------------------------------------------------------
;;; Following function implements the very simple first Komet-Client
;;; exchange protocol, including an escape for further client
;;; handling methods (such as for the simplified
;;; semantic input form (SSIF)  used by the Dictionary of Art experiment
;;; in Example 1 below).
;;;
;;; Protocol is very primitive:
;;;   from client: 
;;;      a - indicates that SPL is going to be sent (acknowledges with o)
;;;          reads the SPL
;;;          returns the generated string bracketted by *
;;;      e - indicates that we're done
;;;      f - paras as for s, but returns the full example structure
;;;          created by KPML.
;;;      i - calls the function: special-client-input-handler for
;;;          further processing; if function returns nil processing
;;;          finishes.
;;;      l - returns the list of examples
;;;      n - does nothing (acknowledges with o)
;;;      s - indicates that SPL, language, and mouseability is to be
;;;          sent (acknowledges with o)
;;;          returns the printable structure from KPML.
;;;      v - returns the language varieties the server is configured for.
;;;      otherwise: noise, looped over...

(defun KPML-SERVER-LOG (message)
  (when *kpml-server-protocol*
    (format *kpml-log-stream* "~%[~A]: ~A" (kpml::time-stamp) message)))

(defun KPML-SHOUT-AND-CLOSE (s)
  (format t "~%;;; KPML server connection on ~A received EOF" s)
  (excl::clear-output-1 s)
  (close s)
  (kpml::close-kpml-server))
  
(defun KPML-SERVER-PROCESSOR (s)
  (loop
   (let ((input nil))
     (kpml-server-log "Waiting-for-input...")
     (setf input (read-char s nil #\e))
     (case input
	   (#\a
	    (write-char #\o s)
	    (kpml-server-log "Acknowledged. (O)")
	    (kpml-server-log "Waiting to receive SPL")
	    (setf input (let ((*package* (find-package "PENMAN")))
			  (read s nil)))
	    (cond ((not input)
		   (kpml-server-log "Eof hit (nil); exiting.")
		   (kpml-shout-and-close s)
		   (return-from KPML-SERVER-PROCESSOR nil))
		  (t
		   (write-char #\* s)
		   (format s "~A" (kpml::say-come-what-may input))
		   (write-char #\* s)
		   (kpml-server-log "Generated result sent to stream.")
		   )))
	   (#\e 
	    (kpml-server-log "Eof (e) hit; exiting.")
	    (kpml-shout-and-close s)
	    (return-from KPML-SERVER-PROCESSOR nil))
	   (#\f
	    (write-char #\o s)
	    (kpml-server-log "Acknowledged. (O)")
	    (kpml-server-log 
	     "Example structure request waiting to be received...")
	    (setf input (let ((*package* (find-package "PENMAN")))
			  (read s nil)))
	    (cond ((not input)
		   (kpml-server-log "Eof hit (nil); exiting.")
		   (kpml-shout-and-close s)
		   (return-from KPML-SERVER-PROCESSOR nil))
		  (t
		   (destructuring-bind (spl language m-consts m-terms)
		       input
		     (write-char #\* s)
		     (format s "~S" (kpml::get-example-structure-for-client
				      spl language m-consts m-terms))
		     (terpri s)
		     (kpml-server-log "Example structure sent to stream." )
		     ))))
	   (#\i
	    (kpml-server-log "Special input handler being called...")
	    (unless (special-client-input-handler s)
	      (kpml-server-log "Special client eof; exiting.")
	      (kpml-shout-and-close s)
	      (return-from KPML-SERVER-PROCESSOR nil)))
	   (#\l
	    (kpml-server-log "Example list request received")
	    (write-char #\o s)
	    (write-char #\* s)
	    (format s "~A" kpml::examples)
	    (terpri s))
	   (#\n
	    (kpml-server-log "Noop received.")
	    (write-char #\o s)
	    (kpml-server-log "Noop acknowledged. (O)"))
	   (#\s
	    (write-char #\o s)
	    (kpml-server-log "Acknowledged. (O)")
	    (kpml-server-log 
	     "Extended generation input waiting to be received...")
	    (setf input (let ((*package* (find-package "PENMAN")))
			  (read s nil)))
	    (cond ((not input)
		   (kpml-server-log "Eof hit (nil); exiting.")
		   (kpml-shout-and-close s)
		   (return-from KPML-SERVER-PROCESSOR nil))
		  (t
		   (destructuring-bind (spl language m-consts m-terms)
		       input
		     (write-char #\* s)
		     (format s "~S" (kpml::say-serving-client
				     spl language m-consts m-terms))
		     (write-char #\* s)
		     (kpml-server-log "Generated result sent to stream." )
		     ))))
	   (#\v
	    (kpml-server-log "Language variety range request received")
	    (write-char #\o s)
	    (write-char #\* s)
	    (format s "~A" kpml::all_languages)
	    (terpri s))
	   (otherwise
	    (kpml-server-log "noise heard.")
	    (write-char #\o s))))))


;;; ----------------------------------------------------------------------
;;; The following function bundles the necessary calls together
;;; to start up the server. It also starts logging the input and output
;;; produced by the server over its life whenever *kpml-server-protocol*
;;; is set T.

(defun START-KPML-SERVER-AND-LOGGING ()
  (kill-lisp-listener-daemon)
  (cond ((and *kpml-log-stream*
	      (open-stream-p *kpml-log-stream*))
	 (close *kpml-log-stream*)
	 (setf *kpml-log-stream* nil))
	(*kpml-log-stream* 
	 (setf *kpml-log-stream* nil)))
  (when *kpml-server-protocol*
    (unless *kpml-log-stream* 
      (setf *kpml-log-stream* 
	(open (make-kpml-log-filename) :direction :output
	      :if-exists :supersede))
      (format t "~%;;;... starting logging to ~A" *kpml-log-stream*)))
  (ipc::start-lisp-server-process :startup-stream-process
				  #'ipc::kpml-server-startup)
  )

(defun KPML::START-KPML-SERVER (&key (logging nil))
  (let ((port *inet-port-used*))
    (setf *kpml-server-protocol* logging)
    (start-kpml-server-and-logging)
    (loop while (eq *inet-port-used* port))
    (set-com-file)
    (format t "~%;;; KPML server started (port: ~A)" *inet-port-used*)
    (values)))

(defun KPML::CLOSE-KPML-SERVER ()
  (kill-lisp-listener-daemon)
  (cond ((and *kpml-log-stream*
	      (streamp *kpml-log-stream*)
	      (open-stream-p *kpml-log-stream*))
	 (kpml-server-log "KPML server connection closing down")
	 (close *kpml-log-stream*)
	 (setf *kpml-log-stream* nil))
	(*kpml-log-stream* 
	 (setf *kpml-log-stream* nil)))
  (format t "~%;;;... KPML server connection closing down.")
  (delete-file kpml::*com-file*))

(defun MAKE-KPML-LOG-FILENAME ()
  (multiple-value-bind 
   (second minute hour date month year) 
   (get-decoded-time)
   (format nil "~A-~a~2,'0D~2,'0D-~2,'0D~2,'0D~2,'0D" 
	   kpml::*kpml-log-file*
	   year month date hour minute second)))



;;; ----------------------------------------------------------------------
;;; Following may need some work for ACL4.3?
(defun KPML::KPML-SERVER-RESTART-FUNCTION ()
  ;; see the ACL manual, p8-8, for the following...
  (let ((f-arg (member "-f" 
		       (system:command-line-arguments :application nil)
		       :test #'string=))
	(l-arg (member "-l"
		       (system:command-line-arguments :application nil)
		       :test #'string=)))
    (kpml::describe-kpml)
    (format t "~%;;; ---------- THIS IS A KPML SERVER IMAGE. ---------- ")
    (if f-arg
	(setf kpml::*com-file* 
	  (pathname
	    (cadr f-arg)))
      (setf kpml::*com-file* kpml::*default-com-file*))
    (cond (l-arg
	   (unless (string= (cadr l-arg) "T")
	     (setf kpml::*kpml-log-file* (cadr l-arg)))
	   (kpml::start-kpml-server :logging T))
	  (t (kpml::start-kpml-server)))))


;;; Straightforwardly adapted from make-kpml-image (0.9.24 for ACL4.3)
;;; 2.1 version ranges added

(defun KPML::MAKE-KPML-SERVER-IMAGE (file-name)
  (in-package :penman)
  (kpml::set-penman-feature :language kpml::all_languages)
  (kpml::set-penman-feature :site (common-lisp:short-site-name))
  #+LUCID
  (lcl::disksave file-name
		 :restart-function #'kpml::kpml-server-restart-function
		 :full-gc t
		 :gc t)
  #+allegro
  (:version-case (":ALLEGRO-V")
		 ((- "4.3")
		  (excl::dumplisp 
		   :name file-name
		   :restart-function #'kpml::kpml-server-restart-function))
		 (t 
		  (setf excl:*restart-init-function* 
		    #'kpml::kpml-server-restart-function)
		  (excl:dumplisp :name file-name)))
  )



;;; ----------------------------------------------------------------------
;;; Simpler, it doesn't get...

(defun KPML::SAY-COME-WHAT-MAY (input)
  (multiple-value-bind (value error)
      (ignore-errors (kpml::say input))
    (if error
	" ... "
      value)))

;;; Following function provides an encapsulated say that makes
;;; sure that globals do not get set for other clients...
;;; Returns NIL if generation failed...

(defun KPML::SAY-SERVING-CLIENT
    (spl language m-consts m-terms)
  (multiple-value-bind (value error)
      (ignore-errors 
       (let ((kpml::*mouse-sensitive-constituents* m-consts)
	     (kpml::*mouse-sensitive-terminals*    m-terms))
	 (multiple-value-bind (string struct)
	     (declare (ignore string))
	   (kpml::say spl :details NIL :full-structure T :language language)
	   struct)))
    (if error
	nil
      value)))

;;; Following provides an encapsulated say but returns not the
;;; string generated but the full example structure...

(defun KPML::GET-EXAMPLE-STRUCTURE-FOR-CLIENT
    (spl language m-consts m-terms)
  (multiple-value-bind (value error)
      (declare (ignore value))
    (ignore-errors 
     (let ((kpml::*mouse-sensitive-constituents* m-consts)
	   (kpml::*mouse-sensitive-terminals*    m-terms)
	   (kpml::store-to-environment-flag      T)
	   (kpml::domain-implemented-value-compare-flag T))
       (kpml::say spl 
		  :details NIL :full-structure NIL :language language)))
    (if error
	nil
      (gethash kpml::*most-recent-example* kpml::penexamples))))


;;; ======================================================================
;;; EXAMPLE 1.     KPML-server as used in the Dictionary of Art
;;;                Scenario (as reported in ERCIM).
;;; ----------------------------------------------------------------------
;;; For the Dictionary of Art scenario, the set up for the server
;;; is as follows:
;;;  (ipc::dart)
;;;  (ipc::set-com-file)
;;;    ... SFK can then communicate using the protocol defined.
;;;  (ipc::close-dart)
;;; then closes the logging files and kills the listener daemon.
;;; ----------------------------------------------------------------------

(defvar *sfk-input-log* nil)
(defvar *server-debugging* nil)

;;; Following function send the Simplified Input Forms (suitably
;;; packaged) on to the Dictionary of Art planner... Uses the
;;; extension slot for the KPML client handler.

;;; Special client protocol for DART...

(defun DART-CLIENT-INPUT-HANDLER (s)
  (let ((input nil))
    (when *kpml-server-protocol* 
      (print "Generation input waiting to be received..." *kpml-log-stream*))
    (setf input (let ((*package* (find-package "PENMAN")))
		  (read s nil)))
    (cond ((not input)
	   (print "Eof hit; exiting." *kpml-log-stream*)
	   (print ";;; KPML server received EOF")
	   (excl::clear-output-1 s)
	   (close s)
	   (kpml::close-kpml-server)
	   (return-from DART-CLIENT-INPUT-HANDLER nil))
	  ((eq input :stop)
	   (print "Server received stop: closing" *kpml-log-stream*)
	   (print ";;; KPML server received stop.")
	   (excl::clear-output-1 s)
	   (close s)
	   (kpml::close-kpml-server)
	   (return-from DART-CLIENT-INPUT-HANDLER nil))
	  (t
	   (write-char #\g s)
	   (when *kpml-server-protocol* 
	     (print "G sent to stream." *kpml-log-stream*))
	   (write-char #\space s)
	   (when *kpml-server-protocol* 
	     (print "Space sent to stream" *kpml-log-stream*))
	   (ipc::process-input-from-dart-client input)
	   (write-char #\a s)
	   (when *kpml-server-protocol* 
	     (print "A sent to stream" *kpml-log-stream*))
	   (format s "~A" kpml::*gen-strings*)
	   (when *kpml-server-protocol* 
	     (print "Generated result sent to stream." *kpml-log-stream*))
	   (setf kpml::*gen-strings* "")
	   (terpri s)
	   T))))


;;; The processing that the server should carry out on its input
;;; should be defined from the following function, which
;;; relies on the function dart-planner to do appropriate dictionary
;;; of Art style stuff---a function stubb is:
(defun kpml::DART-PLANNER (stuff) stuff)


(defun PROCESS-INPUT-FROM-DART-CLIENT (input)
  (when *server-debugging* (print input))
  (when (and (consp input)
	     (consp (first input)))
	(setf input
	      (loop for x in input 
		    when (consp x)
		    collect (loop for y in x
				  when (consp y)
				  collect (loop for z in y
						collect 
						(intern (string z) "PENMAN"))
				  else 
				  when (stringp y)
				  collect y
				  else
				  unless (keywordp y)
				  collect (intern (string y) "PENMAN")
				  else collect y)
		    else collect x end))
	(format t "~%;;; KPML Server found something to generate...")
	(push (cons (kpml::time-stamp) input) *sfk-input-log*)
	(print (first *sfk-input-log*) *kpml-log-stream*)
	(unwind-protect
	    (multiple-value-bind
		(value error)
		(declare (ignore value))
	      (ignore-errors
	       (kpml::dart-planner input))
	      (when error
		(setf kpml::*gen-strings* " ... ")
		(print "Failed to generate!" *kpml-log-stream*))))
	(format *kpml-log-stream*
		"\"~{~%       ~A~}\" "
		(kpml::justify-string 60 kpml::*gen-strings*))
	(return-from process-input-from-dart-client T))
  nil)


;;; ----------------------------------------------------------------------
;;; Announce...

(defun SPECIAL-CLIENT-INPUT-HANDLER (s)
  (dart-client-input-handler s))

;;; ----------------------------------------------------------------------
;;; starting and stopping...

(defun START-DART () (kpml::start-kpml-server))
(defun CLOSE-DART () (kpml::close-kpml-server))

(defun DART () (start-kpml-server-and-logging))

