;;; -*- Mode:Lisp -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Spice Lisp interface to the name server
;;; 
;;; Written by Daniel Aronson
;;;
;;; **********************************************************************

(proclaim '(special *name-server-port*))

(defvar name-server-reply-port ()
  "The port that we get messages back from the nameserver on.")


;;; Return codes:

(defconstant rc-ns-name-not-found 1001)
(defconstant rc-ns-checkin-failed 1000)

;;; CHECKIN  
(defvar to-checkin)
(def-alien-structure to-checkin
  (msg-simplep (selection () t) 0 2 :constant ())
  (msg-size unsigned-integer 2 6 :constant 124)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant name-server-reply-port)
  (msg-remote-port port 14 18 :constant *name-server-port*)
  (msg-id unsigned-integer 18 22 :constant 1000)
  (tt1-1 unsigned-integer 22 24 :constant 2056)
  (tt1-2 unsigned-integer 24 26 :constant 4177)
  (portsname perq-string 26 108)
  (tt2-1 unsigned-integer 108 110 :constant 8198)
  (tt2-2 unsigned-integer 110 112 :constant 4097)
  (signature port 112 116)
  (tt3-1 unsigned-integer 116 118 :constant 8198)
  (tt3-2 unsigned-integer 118 120 :constant 4097)
  (portsid port 120 124)
  )


(defvar from-checkin)
(def-alien-structure from-checkin
  (msg-size unsigned-integer 2 6 :constant 28)
  (msg-local-port port 10 14 :constant name-server-reply-port)
  (rc unsigned-integer 26 28 :direction read)
  )

;;; Checkin allows a process to check in a port to the name server.  PORTSNAME
;;; is the string associated with the port, SIGNATURE is a port that
;;; provides some security (NULL-PORT provides no security), PORTSID is the
;;; port to check in.

(defun checkin (portsname signature portsid)
  "Checkin allows a process to check in a port to the name server.  PORTSNAME
  is the string associated with the port, SIGNATURE is a port that
  provides some security (NULL-PORT provides no security), PORTSID is the
  port to check in.  Returns T if checkin is successful, or NIL if not."
  (multiple-alien-setq-to-checkin to-checkin
				  (:portsname portsname)
				  (:signature signature)
				  (:portsid portsid))
  (simple-send to-checkin)
  (simple-receive from-checkin)
  (= (from-checkin-rc from-checkin) rc-success))
;;; LOOKUP

(defvar to-lookup)
(def-alien-structure to-lookup
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 108)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant name-server-reply-port)
  (msg-remote-port port 14 18 :constant *name-server-port*)
  (msg-id unsigned-integer 18 22 :constant 1001)
  (tt1-1 unsigned-integer 22 24 :constant 2056)
  (tt1-2 unsigned-integer 24 26 :constant 4177)
  (portsname perq-string 26 108)
  )


(defvar from-lookup)
(def-alien-structure from-lookup
  (msg-size unsigned-integer 2 6 :constant 36)
  (msg-local-port port 10 14 :constant name-server-reply-port)
  (rc unsigned-integer 26 28 :direction read)
  (portsid port 32 36 :direction read)
  )

;;; Lookup returns the port registered with the nameserver under the name 
;;; PORTSNAME.

(defun lookup (portsname)
  "Lookup returns the port registered with the nameserver under the name 
  PORTSNAME, or NIL if there is no such port."
  (setf (to-lookup-portsname to-lookup) portsname)
  (simple-send to-lookup)
  (simple-receive from-lookup)
  (cond ((= (from-lookup-rc from-lookup) rc-success)
	 (from-lookup-portsid from-lookup))
	((= (from-lookup-rc from-lookup) rc-ns-name-not-found)
	 nil)
	(t
	 (error "RC = ~a." (from-lookup-rc from-lookup)))))


;;; CHECKOUT

(defvar to-checkout)
(def-alien-structure to-checkout
  (msg-simplep (selection () t) 0 2 :constant ())
  (msg-size unsigned-integer 2 6 :constant 116)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant name-server-reply-port)
  (msg-remote-port port 14 18 :constant *name-server-port*)
  (msg-id unsigned-integer 18 22 :constant 1002)
  (tt1-1 unsigned-integer 22 24 :constant 2056)
  (tt1-2 unsigned-integer 24 26 :constant 4177)
  (portsname perq-string 26 108)
  (tt2-1 unsigned-integer 108 110 :constant 8198)
  (tt2-2 unsigned-integer 110 112 :constant 4097)
  (signature port 112 116)
  )


(defvar from-checkout)
(def-alien-structure from-checkout
  (msg-size unsigned-integer 2 6 :constant 28)
  (msg-local-port port 10 14 :constant name-server-reply-port)
  (rc unsigned-integer 26 28 :direction read)
  )

;;; Checkout allows you to check a port out of the name server.  SIGNATURE must
;;; be the same as what the port was checked in with.

(defun checkout (portsname signature)
  "Checkout allows you to check a port out of the name server.  SIGNATURE must
  be the same as what the port was checked in with."
  (multiple-alien-setq-to-checkout to-checkout
				   (:portsname portsname)
				   (:signature signature))
  (simple-send to-checkout)
  (simple-receive from-checkout)
  (if (/= (from-checkout-rc from-checkout) rc-success)
      (error "RC = ~a." (from-checkout-rc from-checkout)))
  )


(defun msgn-init ()
  (setq name-server-reply-port (allocate-port 0))
  (setq to-checkin (make-to-checkin))
  (setq from-checkin (make-from-checkin))
  (Setq to-lookup (make-to-lookup))
  (setq from-lookup (make-from-lookup))
  (setq to-checkout (make-to-checkout))
  (setq from-checkout (make-from-checkout))
  )