(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2") (il:filecreated " 1-Aug-88 11:51:33" il:{erinyes}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}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 ( ) 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