(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2")

(il:filecreated " 1-Aug-88 11:51:33" il:{erinyes}<lispusers>medley>rpcrpc.\;2
 38993  

      il:|changes| il:|to:|  (il:functions define-remote-program)

      il:|previous| il:|date:| "28-Apr-88 17:26:39" il:{erinyes}<lispusers>medley>rpcrpc.\;1)


; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation.  All rights reserved.

(il:prettycomprint il:rpcrpccoms)

(il:rpaqq il:rpcrpccoms

          ((il:props (il:rpcrpc il:makefile-environment il:filetype))
           (il:variables *debug* *rpc-call* *rpc-version* *rpc-programs* *msec-until-timeout* 
                  *msec-between-tries* *internal-time-units-per-msec* *rpc-reply-stats* 
                  *rpc-accept-stats* *rpc-reject-stats* *rpc-authentication-stats* *rpc-ok-to-cache*
                  *rpc-socket-cache* *xid-count* *rpc-def-in-progress* *rpc-well-known-sockets* 
                  *rpc-protocols* *rpcstream* *rpc-pgname* *rpc-pcname*)
           

(il:* il:|;;;| "Define RPC Program")


           (il:functions define-remote-program define-remote-prog cons-up-rpc-procs 
                  clear-any-name-conflicts def-rpc-types def-rpc-inherits def-rpc-procedures 
                  def-rpc-procedure def-rpc-constants undefine-remote-program xdr-gencode-makefcn 
                  xdr-gencode-inline)
           

(il:* il:|;;;| "Remote Procedure Call")


           (il:functions remote-procedure-call setup-rpc perform-rpc rpc-resolve-host 
                  rpc-resolve-prog rpc-resolve-proc rpc-find-socket encode-rpc-args 
                  actually-do-the-rpc exchange-udp-packets exchange-tcp-packets parse-rpc-reply 
                  create-xid)
           

(il:* il:|;;;| "RPC Utility Functions")


           (il:functions get-reply-stat get-accept-stat get-reject-stat get-authentication-stat 
                  get-protocol-number find-cached-socket)
           

(il:* il:|;;;| "RPC Error Messages")


           (il:functions rpc-error-prm-mismatch rpc-error-prm-unavailable rpc-error-prc-unavailable 
                  rpc-error-garbage-args rpc-error-mismatch rpc-error-authentication)
           

(il:* il:|;;;| "Authentication")


           (il:variables *authentication-typedef* *null-authentication*)
           (il:functions create-unix-authentication encode-authentication decode-authentication)))

(il:putprops il:rpcrpc
 il:makefile-environment
 (:readtable "XCL" :package "RPC2"))

(il:putprops il:rpcrpc
 il:filetype
 :compile-file)

(defglobalparameter *debug*
 nil
   "T for printout, NUMBER for even more.")

(defconstant *rpc-call*
 0
   "Constant 0 in packet means RPC call, 1 means reply")

(defconstant *rpc-version*
 2
   "This code will only work for SUN RPC Version 2")

(defglobalvar *rpc-programs*
 nil
   "
A list of RPC-PROGRAM structs.

This list is consulted by various routines to find infomation about known
remote programs.

It is assumed that a given NAME field uniquely identifies a (NUMBER, VERSION, PROTOCOL).
On the other hand, there may be several NAMEs (and hence, several RPC-STRUCTs) for
a given (NUMBER, VERSION, PROTOCOL).

")

(defparameter *msec-until-timeout*
 10000
   "Total time in msec before giving up on UDP exchange with remote host")

(defparameter *msec-between-tries*
 1000
   "Time in msec between UDP retries")

(defconstant *internal-time-units-per-msec*
 (/ internal-time-units-per-second 1000)
                                                "This gets used in EXCHANGE-UDP-PACKETS.")

(defconstant *rpc-reply-stats*
 '((0 . accepted)
                                     (1 . rejected))
                                   "
Assoc list for internal use by PARSE-RPC-REPLY.
")

(defconstant *rpc-accept-stats*
 '((0 . success)
                                      (1 . program-unavailable)
                                      (2 . program-mismatch)
                                      (3 . procedure-unavailable)
                                      (4 . garbage-arguments))
                                    "
Assoc list for internal use by PARSE-RPC-REPLY.
")

(defconstant *rpc-reject-stats*
 '((0 . rpc-mismatch)
                                      (1 . authentication-error))
                                    "
Assoc list for internal use by PARSE-RPC-REPLY.
")

(defconstant *rpc-authentication-stats*
 '((1 . bad-credential)
                                              (2 . rejected-credential)
                                              (3 . bad-verifier)
                                              (4 . rejected-verifier)
                                              (5 too-weak))
                                            "NIL")

(defparameter *rpc-ok-to-cache*
 t
   "
If NIL, does not attempt to cache socket numbers for non-well-known sockets
")

(defvar *rpc-socket-cache*
 nil
   "
A list of (<iphost-address> <remote-program-name> <remote-program-version>
           <protocol> <ipsocket-number>) quintuples.")

(defvar *xid-count*
 0
   "Contains the  XID stamp of the next remote procedure call")

(defvar *rpc-def-in-progress*
 nil
   "Used for debugging only")

(defglobalvar *rpc-well-known-sockets*

   `((* 100000 2 udp 111)
     (* 100000 2 tcp 111)
     (* 100003 2 udp 2049))
   "
List of well-known RPC programs and their sockets.
Each element is a list:
  (host-address prog-number prog-version protocol socket-number)

Host-address may be *, in which case it matches any host address.
Protocol should be either rpc2::UDP or rpc2::TCP.
")

(defvar *rpc-protocols*
 '((tcp . 6)
                              (udp . 17)))

(defvar *rpcstream*
 nil
   "This global is not used exceptin debugging.
 It holds a copy of the RPC-STREAM even after the RPC-CALL returns.")

(defglobalvar *rpc-pgname*
 nil
   "Name of RPC Program. Used only for *debug* printout.")

(defglobalvar *rpc-pcname*
 nil
   "Name of RPC Procedure. Used only for *debug* printout.")



(il:* il:|;;;| "Define RPC Program")



(defmacro define-remote-program
 (name number version protocol &key constants types inherits 
                                          procedures)
   "
This macro expands into code to add a new RPC-PROGRAM struct to
*RPC-PROGRAMS*. The generated code checks first to see that there
are no name conflicts with existing remote programs and then adds the new
structure to *RPC-PROGRAMS*.
"
   (let ((ename (eval name))
         (enumber (eval number))
         (eversion (eval version))
         (eprotocol (or (eval protocol)
                        'udp))
         (econstants (eval constants))
         (etypes (eval types))
         (einherits (eval inherits))
         (eprocedures (eval procedures)))
        (check-type ename symbol)
        (check-type enumber number)
        (check-type eversion number)
        (cond
           ((member eprotocol '(udp tcp))
            (if (and *use-os-networking* (eq eprotocol 'tcp))
                (error "~a is an unsupported protocol." eprotocol)
                t))
           ((equal "UDP" (string eprotocol))
            (setq eprotocol 'udp))
           ((equal "TCP" (string eprotocol))
            (if *use-os-networking*
                (error "~a is an unsupported protocol." eprotocol)
                (setq eprotocol 'tcp)))
           ((error "~a is unknown prototype." eprotocol)))
        (let ((rprog (define-remote-prog ename enumber eversion eprotocol econstants etypes einherits
                            eprocedures)))
             `(let ((dummy (format-t "Defining remote program ~a, version ~a~%" ',ename
                                  ',eversion))
                    (newprog (make-rpc-program :number ,enumber :version ,eversion :name
                                    ',ename :protocol ',eprotocol :types ',(rpc-program-types rprog)
                                    :constants
                                    ',(rpc-program-constants rprog)
                                    :inherits
                                    ',(rpc-program-inherits rprog)
                                    :procedures
                                    ,(cons-up-rpc-procs (rpc-program-procedures rprog)))))
                   (if (clear-any-name-conflicts ',ename ',enumber ',eversion ',eprotocol)
                       (progn (undefine-remote-program ',ename ',enumber ',eversion)
                              (push newprog *rpc-programs*)
                              ',ename)
                       (progn (format-t "Old RPC program not overwritten.~%")
                              nil))))))

(defun define-remote-prog
 (name number version protocol constants types inherits procedures)

   (il:* il:|;;| 

 "This guy does the work, so that DEFINE-REMOTE-PROGRAM can cons up the macro easily.")


   (il:* il:|;;| "An RPC-PROGRAM struct RPROG is passed back to DEFINE-REMOTE-PROGRAM. Its innards are then used by DEFINE-REMOTE-PROGRAM to build up the big cons that will cons up the proper RPC-PROGRAM later.")


   (let (rprog)
        (format-t "Building XDR routines for remote program ~a, version ~a~%" name version)
        (setq rprog (make-rpc-program :number number :version version :name name :protocol protocol)
              *rpc-def-in-progress* rprog)
        (setf (rpc-program-types rprog)
              (def-rpc-types rprog types))
        (setf (rpc-program-inherits rprog)
              (def-rpc-inherits rprog inherits))
        (setf (rpc-program-constants rprog)
              (def-rpc-constants rprog constants))
        (setf (rpc-program-procedures rprog)
              (def-rpc-procedures rprog procedures))
        rprog))

(defun cons-up-rpc-procs
 (procs)
   "
Given a list of RPC-PROCEDURE structs, conses up code to produce that set of
RPC-PROCEDURE structs.
"
   `(list
     ,@(map
        'list
        #'(lambda
           (proc)
           `(make-rpc-procedure
             :name
             ',(rpc-procedure-name proc)
             :procnum
             ',(rpc-procedure-procnum proc)
             :argtypes
             ,(if (rpc-procedure-argtypes proc)
                  `(list ,@(map 'list #'(lambda (fcn)
                                               (list 'function fcn))
                                (rpc-procedure-argtypes proc))))
             :resulttypes
             ,(if (rpc-procedure-resulttypes proc)
                  `(list ,@(map 'list #'(lambda (fcn)
                                               (list 'function fcn))
                                (rpc-procedure-resulttypes proc))))))
        procs)))

(defun clear-any-name-conflicts
 (name number version protocol)
   "
Determines whether a proposed (NAME, NUMBER, VERSION, PROTOCOL) would violate
the assumption that a NAME uniquely specifies the other three components.

If there exists a violation, the user is given a chance to remove the old program.

Returns T if no violation of assumption (or violation is resolved by removing old program),
Returns NIL if there is an unresolved violation.

"
   (let (oldrpc)
        (cond
           ((and (setq oldrpc (find-rpc-program :name name))
                 (or (/= number (rpc-program-number oldrpc))
                     (/= version (rpc-program-version oldrpc))
                     (not (eql protocol (rpc-program-protocol oldrpc)))))
            (format *query-io* "Remote program name conflict with existing program:~%   Name ~a, Protocol ~A, Number ~a, Version ~a~%"
                   name (rpc-program-protocol oldrpc)
                   (rpc-program-number oldrpc)
                   (rpc-program-version oldrpc))
            (and (yes-or-no-p "Do you want to remove the old program? ")
                 (undefine-remote-program (rpc-program-name oldrpc)
                        (rpc-program-number oldrpc)
                        (rpc-program-version oldrpc)
                        (rpc-program-protocol oldrpc))))
           (t t))))

(defun def-rpc-types
 (context typedefs)
   "
Essentially a no-op, as typedefs are copied directly from the DEFINE-REMOTE-PROGRAM
into the RPC-PROGRAM struct. Just prints out the name of each type as it is encountered.
"
   (if typedefs (format-t "    Types~%"))
   (dolist (i typedefs)
       (format-t "        ~A~%" (first i)))
   typedefs)

(defun def-rpc-inherits
 (context proglist)
   "
Checks remote program inherited by this one to make sure that it exists.
Issues a warning if it cannot find the program to be inherited.
"
   (if proglist (format-t "    Inherits~%"))
   (dolist (prg proglist proglist)
       (format-t "        ~A~%" prg)
       (if (not (and (symbolp prg)
                     (find-rpc-program :name prg)))
           (warn "Trying to inherit from remote program ~a, but ~a not found.~%" prg prg))))

(defun def-rpc-procedures
 (context procs)
   "Returns a list of RPC-PROCEDURE structs returned by DEF-RPC-PROCEDURE."
   (check-type procs list "A list of RPC procedure declarations")
   (if procs (format-t "    Procedures~%"))
   (map 'list #'(lambda (proc)
                       (def-rpc-procedure context proc))
        procs))

(defun def-rpc-procedure
 (context proc)
   "
For a procedure specified to DEFINE-REMOTE-PROGRAM's :PROCEDURES argument,
creates and returns an RPC-PROCEDURE struct. 

XDR procedure code is generated via the call to XDR-GENCODE-MAKEFCN.
"
   (check-type (first proc)
          (and symbol (not null))
          "a non-null symbol naming the RPC procedure.")
   (check-type (second proc)
          (integer 0 *)
          "a non-negative integer RPC procedure number")
   (check-type (third proc)
          list)
   (check-type (fourth proc)
          list)
   (let ((rp (make-rpc-procedure)))
        (setf (rpc-procedure-name rp)
              (first proc))
        (setf (rpc-procedure-procnum rp)
              (second proc))
        (setf (rpc-procedure-argtypes rp)
              (map 'list #'(lambda (td)
                                  (xdr-gencode-makefcn context td 'write))
                   (third proc)))
        (setf (rpc-procedure-resulttypes rp)
              (map 'list #'(lambda (td)
                                  (xdr-gencode-makefcn context td 'read))
                   (fourth proc)))
        (format-t "        ~A~%" (rpc-procedure-name rp))
        rp))

(defun def-rpc-constants
 (context pairs)
   "
Checks that constants specified to DEFINE-REMOTE-PROGRAM are syntactically
reasonable.
"
   (if pairs (format-t "    Constants~%"))
   (dolist (pair pairs)
       (check-type (first pair)
              (and (not null)
                   symbol))
       (check-type (second pair)
              (and (not null)
                   number))
       (format-t "        ~A~%" (first pair)))
   pairs)

(defun undefine-remote-program
 (name number version &optional (protocol 'udp))
   "
If finds NAME-NUMBER-VERSION-PROTOCOL match in *RPC-PROGRAMS*, deletes.
If finds NUMBER-VERSION match with NAME mismatch, asks first.
If deletes something, returns NAME of DELETED program, otherwise NIL."
                                                             (il:* il:\; "")

   (let ((rpc (find-rpc-program :number number :version version :name name :protocol protocol)))
        (if rpc
            (if (or (eql name (rpc-program-name rpc))
                    (yes-or-no-p "Do you really want to remove/overwrite RPC program ~a?"
                           (rpc-program-name rpc)))
                (progn (setq *rpc-programs* (delete rpc *rpc-programs*))
                       (rpc-program-name rpc))))))

(defun xdr-gencode-makefcn
 (context typedef oper &optional compilesw)
   "
Calls XDR-CODEGEN to generate an XDR function for TYPEDEF.
If COMPILESW, then compiles the function. COMPILESW is not
used anymore since DEFINE-REMOTE-PROGRAM became a macro.
"
   (let ((code (xdr-codegen context typedef oper)))
        (if compilesw
            (compile nil code)
            code)))

(defmacro xdr-gencode-inline
 (context typedef oper &rest vars)
   "NIL"

   (il:* il:|;;| " Note that using a NIL context is valid here. It just means that no typedefs from other Remote Program Definitions are available.")


   "NIL"
   `(funcall #',(xdr-codegen context (eval typedef)
                       (eval oper))
           ,.vars))



(il:* il:|;;;| "Remote Procedure Call")



(defun remote-procedure-call
 (destination program procid arglist &key (protocol 'udp)
                                        remotesocket version credentials dynamic-prognum (
                                                                                      dynamic-version
                                                                                          1)
                                        (errorflg t)
                                        leave-stream-open
                                        (msec-until-timeout *msec-until-timeout*)
                                        (msec-between-tries *msec-between-tries*)
                                        results)
   "
This is the high-level way of making a remote procedure call (PERFORM-RPC is the low-level
way).

REMOTE-PROCEDURE-CALL resolves all the arguments, creates a new RPC-STREAM, makes the call, optionally closes the RPC-STREAM, and returns the results of the call.

The resolution of arguments is designed such that all arguments may be either
unresolved (e.g., a remote host name), or already resolved (e.g., an IP address).
"
   (when (numberp *debug*)
       (format-t "Remote-Procedure-Call...~%")
       (format-t "  Destination=~A~%" destination)
       (format-t "  Program=~A~%" program)
       (format-t "  ProcID=~A~%" procid)
       (format-t "  ArgList=~A~%" arglist))
   (multiple-value-bind (destaddr destsocket rprog rproc rpcstream)
          (setup-rpc destination program procid remotesocket version dynamic-prognum dynamic-version
                 protocol)
          (setq rpcstream (open-rpcstream (rpc-program-protocol rprog)
                                 destaddr destsocket))
          (setq results (perform-rpc destaddr destsocket rprog rproc rpcstream arglist credentials 
                               :errorflg errorflg :msec-until-timeout msec-until-timeout 
                               :msec-between-tries msec-between-tries))
          (unless leave-stream-open (close-rpcstream rpcstream))
          results))

(defun setup-rpc
 (destination program procid &optional destsocket version dynamic-prognum 
                            dynamic-version (protocol 'udp))
   "
Resolves arguments to REMOTE-PROCEDURE-CALL. Takes arguments in more or less
any reasonable form and returns multiple values (destination-address, socket-number,
RPC-PROGRAM struct, RPC-PROCEDURE struct).
 
See individual RPC-RESOLVE-* programs for details on what inputs are acceptable.
"
   (let* ((destaddr (rpc-resolve-host destination))
          (rprog (rpc-resolve-prog program version protocol))
          (dummy                                             (il:* il:\; " This code may set RPROG")

                 (when dynamic-prognum
                     (setf rprog (copy-rpc-program rprog))
                     (setf (rpc-program-number rprog)
                           dynamic-prognum)
                     (setf (rpc-program-version rprog)
                           dynamic-version)))
          (rproc (rpc-resolve-proc rprog procid))
          (socket (or destsocket (rpc-find-socket destaddr rprog (rpc-program-protocol rprog)))))
         (values destaddr socket rprog rproc)))

(defun perform-rpc
 (destaddr destsocket rprog rproc stream arglist credentials &key (errorflg
                                                                                         t)
                              (msec-until-timeout *msec-until-timeout*)
                              (msec-between-tries *msec-between-tries*))
   "
The low-level remote procedure call function.
"
   (let (retvals)
        (reinitialize-rpcstream stream destaddr destsocket)
        (progn 
               (il:* il:|;;| " These are for debugging printouts only")


               (setq *rpcstream* stream)
               (setq *rpc-pgname* (rpc-program-name rprog))
               (setq *rpc-pcname* (rpc-procedure-name rproc)))
        (xdr-unsigned stream (create-xid))
        (xdr-unsigned stream *rpc-call*)
        (xdr-unsigned stream *rpc-version*)
        (xdr-unsigned stream (rpc-program-number rprog))
        (xdr-unsigned stream (rpc-program-version rprog))
        (xdr-unsigned stream (rpc-procedure-procnum rproc))
        (encode-authentication stream credentials)
        (encode-authentication stream *null-authentication*)
        (encode-rpc-args stream arglist rproc)
        (setq retvals (catch 'goforit
                          (actually-do-the-rpc stream msec-until-timeout msec-between-tries errorflg)
                          (parse-rpc-reply stream (rpc-procedure-resulttypes rproc)
                                 errorflg)))
        (when (and (numberp *debug*)
                   (> *debug* 0))
              (format-t " Values Returned by RPC: ~A~%" retvals))
        retvals))

(defun rpc-resolve-host
 (destination)
   "
Takes an IPADDRESS, symbol, or string and tries to find an IPADDRESS for a remote
host. Signals an error if it cannot resolve the host.
"
   (or (typecase destination
           (number destination)
           (symbol (if *use-os-networking*
                       (os-resolve-host (string destination))
                       (il:iphostaddress destination)))
           (string (if *use-os-networking*
                       (os-resolve-host destination)
                       (il:iphostaddress (intern destination))))
           (t (il:\\illegal.arg destination)))
       (error "Could not find an IP net address for DESTINATION ~A" destination)))

(defun rpc-resolve-prog
 (program &optional version protocol)
   "
Takes an RPC-PROGRAM, a number, a symbol, or a string along with an optional VERSION and PROTOCOL and tries to find the matching RPC-PROGRAM.
Signals an error if it cannot find the intended program.
"
   (cond
      ((typep program 'rpc-program)
       program)
      ((and (typep program 'symbol)
            (find-rpc-program :name program :version version :protocol protocol)))
      ((and (numberp program)
            (find-rpc-program :number program :version version :protocol protocol)))
      ((and (stringp program)
            (find-rpc-program :name (intern program)
                   :version version :protocol protocol)))
      (t (error "Could not find definition for program ~a~a~a.~%" program
                (if version
                    (format nil ", version ~a" version)
                    "")
                (if protocol
                    (format nil ", protocol ~a" protocol)
                    "")))))

(defun rpc-resolve-proc
 (rprog procid)
   "
Given an RPC-PROGRAM struct RPROG, tries to find and return an RPC-PROCEDURE in
RPROG specified by a number, string,  symbol, or RPC-PROCEDURE.

Signals an error if it cannot find the intended rpc-procedure
"
   (cond
      ((typep procid 'rpc-procedure)
       procid)
      ((and (or (numberp procid)
                (symbolp procid))
            (find-rpc-procedure (rpc-program-procedures rprog)
                   procid)))
      ((and (stringp procid)
            (find-rpc-procedure (rpc-program-procedures rprog)
                   (intern procid))))
      (t (error "Could not find definition for program ~a, procedure ~a~%" (rpc-program-name rprog)
                procid))))

(defun rpc-find-socket
 (destaddr prg protocol)
   "
Tries to find and return a remote socket number.

(1) Looks in *RPC-WELL-KNOWN-SOCKETS*,
(2) Looks in *RPC-SOCKET-CACHE*, but only if *RPC-OK-TO-CACHE*,
(3) Requests socket number via remote procedure call to Portmapper
on remote machine. If found and *RPC-OK-TO-CACHE*, caches the new
socket number on *RPC-SOCKET-CACHE*.
(4) If all the above have failed, signals an error.
"
   (let ((prognum (rpc-program-number prg))
         (progvers (rpc-program-version prg))
         skt)
        (cond
           ((setq skt (find-cached-socket '* prognum progvers protocol *rpc-well-known-sockets*))
            (if *debug*
                (format-t "Cached well-known socket ~a found for program ~a~%" skt (rpc-program-name
                                                                                    prg)))
            skt)
           ((and *rpc-ok-to-cache* (setq skt (find-cached-socket destaddr prognum progvers protocol 
                                                    *rpc-socket-cache*)))
            (if *debug*
                (format-t "Cached non-well-known socket ~a found for program ~a~%" skt (
                                                                                     rpc-program-name
                                                                                        prg)))
            skt)
           ((progn (if *debug*
                       (format-t "Looking up socket for program ~a on ~a.~%" (rpc-program-name prg)
                              destaddr))
                   (setq skt (first (remote-procedure-call destaddr 'portmapper 'lookup
                                           `(,(rpc-program-number prg)
                                             ,(rpc-program-version prg)
                                             ,(get-protocol-number protocol)
                                             0)
                                           :remotesocket 111)))
                   (if *debug*
                       (format-t "Socket ~a found via portampper on ~a for program ~a~%" skt destaddr
                              (rpc-program-name prg)))
                   (if (and *rpc-ok-to-cache* (> skt 0))
                       (push `(,destaddr ,prognum ,progvers ,protocol ,skt)
                             *rpc-socket-cache*)
                       skt)
                   (if (> skt 0)
                       skt)))
           ((error "Could not find remote socket number for~%~
   Host ~a, Remote Program ~a, Number ~a, Version ~a, Protocol ~a" destaddr (rpc-program-name prg)
                   prognum progvers protocol)))))

(defun encode-rpc-args
 (stream arglist rpc-proc)
   "
Takes a list of arguments and the corresponding list of XDR procedures and
converts the arguments into XDR, writing them into the RPC-STREAM.
"
   (when (and (numberp *debug*)
              (> *debug* 0))
         (format-t "  RPC Arguments: ~A~%" arglist))
   (do ((xdr-fns (rpc-procedure-argtypes rpc-proc)
               (rest xdr-fns))
        (args arglist (rest args)))
       ((or (null args)
            (null xdr-fns))
        (if (or xdr-fns args)
            (error "Mismatch of arguments and parameters to RPC call.~
              Number or arguments:~a, Number of parameters:~a" (length arglist)
                   (length (rpc-procedure-argtypes rpc-proc)))
            (rpc-procedure-name rpc-proc)))
     (funcall (first xdr-fns)
            stream
            (first args))))

(defun actually-do-the-rpc
 (stream msec-until-timeout msec-between-tries errorflg)
   "
Calls the appropriate function (for the protocol) to actually send the packets over
the net and await an answer.
"
   (ecase (rpc-stream-protocol stream)
       (udp (if *use-os-networking*
                (os-exchange-udp-packets stream msec-until-timeout msec-between-tries errorflg)
                (exchange-udp-packets stream msec-until-timeout msec-between-tries errorflg)))
       (tcp (exchange-tcp-packets stream msec-until-timeout errorflg))))

(defun exchange-udp-packets
 (stream msec-until-timeout msec-between-tries errorflg)
   "
Given the specified timeout and time between tries, this routine continues
to send out UDP packets until it either gets a reply or times out.
"
   (if (and (numberp *debug*)
            (> *debug* 5))
       (break "Packet ready to go from PACKET of *RPCSTREAM*"))
   (do* ((init-time (get-internal-real-time))
         (final-time (+ init-time (* msec-until-timeout *internal-time-units-per-msec*))))
        ((>= (get-internal-real-time)
             final-time)
         (case errorflg
             (:noerrors (throw 'goforit nil))
             (:returnerrors (throw 'goforit '(error timeout)))
             (otherwise (error "Timeout of RPC Call"))))
      (when *debug* (format-t "Trying RPC Call: Program ~a, Procedure ~a...~%" *rpc-pgname* 
                           *rpc-pcname*))
      (if (setf (rpc-stream-instream stream)
                (il:udp.exchange (rpc-stream-ipsocket stream)
                       (rpc-stream-outstream stream)
                       msec-between-tries))
          (progn (when *debug*
                     (format-t "It returned!~%")
                     (and (numberp *debug*)
                          (> *debug* 5)
                          (break "Reply Packet in INSTREAM of RPC-STREAM *RPCSTREAM*")))
                 (return t)))))

(defun exchange-tcp-packets
 (rpcstream timeout &optional errorflg)
   "
Given the specified timeout, this routine writes onto the TCP stream and 
waits until it either gets a reply or times out.
"
   (il:* il:|;;| 

 "Yes, I know EXCHANGE-TCP-PACKETS is a misnomer, but I wanted it to parallel Exchange-UDP-Packets")


   (let* ((outstring (rpc-stream-outstring rpcstream))
          (outstream (rpc-stream-outstream rpcstream))
          (instream (rpc-stream-instream rpcstream))
          (event (il:tcp.socket.event (il:tcp.stream.socket (rpc-stream-outstream rpcstream)))))
         (when (numberp *debug*)
             (inspect-string1 outstring (rpc-stream-outbyteptr rpcstream))
             (and (> *debug* 4)
                  (break "Ready to write to tcp stream")))
         (rm-forceoutput rpcstream t)
         (il:forceoutput outstream t)
         (if *debug* (format-t "Output forced out. Will wait ~a msec for reply~%" timeout))
         (il:await.event (il:tcp.socket.event (il:tcp.stream.socket (rpc-stream-outstream rpcstream))
                                )
                timeout nil)
         (if (il:readp instream)
             (progn (if *debug* (format-t "It returned!!!!~%"))
                    (rm-new-input-record rpcstream)
                    t)
             (case errorflg
                 (:noerrors (throw 'goforit nil))
                 (:returnerrors (throw 'goforit '(error timeout)))
                 (otherwise (error "Timeout of TCP Call after ~a msec.~%" timeout))))))

(defun parse-rpc-reply
 (rpcstream rettypes &optional errorflg)
   "
Parses a reply message. If all goes well, returns a list of the values returned (or T if RETTYPES is NIL).

If RPC was REJECTED, or ACCEPTED but with an ACCEPT-STAT other than SUCCESS,
then  (Following Courier) the response depends on the value of ERRORFLG:
	If ERRORFLG = 'NOERROR, then returns NIL
	If ERRORFLG = 'RETURNERRORS, then returns a list of the form
		(ERROR reply-stat accept-or-reject-stat otherinfo)
	If ERRORFLG = anything else, signals Lisp error.

"                                                            (il:* il:\; " ")

   (let (xid msgtype reply-stat verf accept-stat reject-stat)
        (setq xid (xdr-unsigned rpcstream))
        (setq msgtype (xdr-unsigned rpcstream))
        (if (not (eql msgtype 1))
            (error "RPC message is not a reply. MSGTYPE is ~A" msgtype))
        (case (get-reply-stat (setq reply-stat (xdr-unsigned rpcstream)))
            (accepted 
               (setq verf (decode-authentication rpcstream))
               (case (get-accept-stat (setq accept-stat (xdr-unsigned rpcstream)))
                   (success (if (null rettypes)
                                t
                                (do ((rs rettypes (cdr rs))
                                     (vals))
                                    ((null rs)
                                     (nreverse vals))
                                  (push (funcall (car rs)
                                               rpcstream)
                                        vals))))
                   (program-mismatch (rpc-error-prm-mismatch errorflg reply-stat accept-stat
                                            (xdr-unsigned rpcstream)
                                            (xdr-unsigned rpcstream)))
                   (program-unavailable (rpc-error-prm-unavailable errorflg reply-stat accept-stat))
                   (procedure-unavailable (rpc-error-prc-unavailable errorflg reply-stat accept-stat))
                   (garbage-arguments (rpc-error-garbage-args errorflg reply-stat accept-stat))))
            (rejected (case (get-reject-stat (setq reject-stat (xdr-unsigned rpcstream)))
                          (rpc-mismatch (rpc-error-mismatch errorflg reply-stat accept-stat
                                               (xdr-unsigned rpcstream)
                                               (xdr-unsigned rpcstream)))
                          (authentication-error (rpc-error-authentication errorflg reply-stat 
                                                       reject-stat (xdr-unsigned rpcstream)))
                          (otherwise (error "Unknown  RPC reply status: ~A" reply-stat)))))))

(defun create-xid
 ()
   "Returns a number to use as the ID of a given transmisssion."
   (setq *xid-count* (logand twoto32minusone (+ 1 *xid-count*))))



(il:* il:|;;;| "RPC Utility Functions")



(defun get-reply-stat
 (number)
   "Map number to corresponding reply-stat symbol of remote procedure call"
   (cdr (assoc number *rpc-reply-stats*)))

(defun get-accept-stat
 (number)
   "Map number to corresponding accept-stat symbol of remote procedure call"
   (cdr (assoc number *rpc-accept-stats*)))

(defun get-reject-stat
 (number)
   "Map number to corresponding reject-stat symbol of remote procedure call"
   (cdr (assoc number *rpc-reject-stats*)))

(defun get-authentication-stat
 (number)
   "Map number to corresponding authentication-stat symbol of remote procedure call"
   (cdr (assoc number *rpc-authentication-stats*)))

(defun get-protocol-number
 (protocol)
   "Map protocol name (e.g., RPC2::UDP) to corresponding protocol number (e.g., 17)"
   (or (cdr (assoc protocol *rpc-protocols*))
       (error "Could not find number for protocol ~a in *RPC-PROTOCOLS*" protocol)))

(defun find-cached-socket
 (destaddr prognum progvers protocol cache)
   "Looks up a given (DESTADDR, PROGNUM, PROGVERS, PROTOCOL) in the specified CACHE."
   (fifth (find-if #'(lambda (quint)
                            (and (eql (first quint)
                                      destaddr)
                                 (eql (second quint)
                                      prognum)
                                 (eql (third quint)
                                      progvers)
                                 (eql (fourth quint)
                                      protocol)))
                 cache)))



(il:* il:|;;;| "RPC Error Messages")



(defun rpc-error-prm-mismatch
 (errorflg reply-stat accept-stat low high)
   "NIL"
   (case errorflg
       (:noerrors nil)
       (:returnerrors `(error ,(get-reply-stat reply-stat)
                              ,(get-accept-stat accept-stat)
                              `(,low ,high)))
       (otherwise (error "RPC Program Mismatch: High: ~A Low: ~A" low high))))

(defun rpc-error-prm-unavailable
 (errorflg reply-stat accept-stat)
   "NIL"
   (case errorflg
       (:noerrors nil)
       (:returnerrors `(error ,(get-reply-stat reply-stat)
                              ,(get-accept-stat accept-stat)))
       (otherwise (error "RPC Program Unavailable"))))

(defun rpc-error-prc-unavailable
 (errorflg reply-stat accept-stat)
   "NIL"
   (case errorflg
       (:noerrors nil)
       (:returnerrors `(error ,(get-reply-stat reply-stat)
                              ,(get-accept-stat accept-stat)))
       (otherwise (error "RPC Procedure Unavailable"))))

(defun rpc-error-garbage-args
 (errorflg reply-stat accept-stat)
   "NIL"
   (case errorflg
       (:noerrors nil)
       (:returnerrors `(error ,(get-reply-stat reply-stat)
                              ,(get-accept-stat accept-stat)))
       (otherwise (error "RPC Garbage Arguments"))))

(defun rpc-error-mismatch
 (errorflg reply-stat reject-stat low high)
   "NIL"
   (case errorflg
       (:noerrors nil)
       (:returnerrors `(error ,(get-reply-stat reply-stat)
                              ,(get-reject-stat reject-stat)
                              `(,low ,high)))
       (otherwise (error "RPC Mismatch: High: ~A Low: ~A" low high))))

(defun rpc-error-authentication
 (errorflg reply-stat reject-stat authentication-stat)
   "NIL"
   (case errorflg
       (:noerrors nil)
       (:returnerrors `(error ,(get-reply-stat reply-stat)
                              ,(get-reject-stat reject-stat)
                              ,(get-authentication-stat authentication-stat)))
       (otherwise (error "Authorization Error: ~A" (get-authentication-stat authentication-stat)))))



(il:* il:|;;;| "Authentication")



(defconstant *authentication-typedef*

   '(:struct authentication (type (:enumeration (:null 0)
                                         (:unix 1)
                                         (:short 2)))
           (string :string))
   "NIL")

(defconstant *null-authentication*
 (make-authentication :type :null :string ""))

(defun create-unix-authentication
 (stamp machine-name uid gid gids)
   "
Given the fields of a Unix authentication, creates an AUTHENTICATION struct with
these fields encoded as a string.
"
   (let ((unix-auth (make-authentication))
         (tempstream (create-string-rpc-stream)))
        (xdr-unsigned tempstream stamp)
        (xdr-string tempstream machine-name)
        (xdr-unsigned tempstream uid)
        (xdr-unsigned tempstream gid)
        (xdr-gencode-inline nil '(:counted-array :unsigned)
               'write tempstream gids)
        (setf (authentication-type unix-auth)
              :unix)
        (setf (authentication-string unix-auth)
              (get-output-stream-string (rpc-stream-outstream tempstream)))
        unix-auth))

(defun encode-authentication
 (rpcstream auth)
   "
Given an AUTHENTICATION struct, converts the struct to its XDR encoding and writes it to
the RPC-STREAM specified.
"
   (if (null auth)
       (setq auth *null-authentication*))
   (check-type auth authentication)
   (xdr-gencode-inline nil *authentication-typedef* 'write rpcstream auth))

(defun decode-authentication
 (rpcstream)
   "
Reads an authentication from specified RPC-STREAM and returns it as an AUTHENTICATION
struct.
"
   (xdr-gencode-inline nil *authentication-typedef* 'read rpcstream))
(il:putprops il:rpcrpc il:copyright ("Stanford University and Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop