(FILECREATED "12-Mar-86 09:42:54" {ERIS}<LISPUSERS>KOTO>RPC.;8 86024
changes to: (FNS \MarshalString)
previous date: "10-Jan-86 18:37:17" {ERIS}<LISPUSERS>KOTO>RPC.;7)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT RPCCOMS)
(RPAQQ RPCCOMS ((* Top Level functions)
(FNS InitRPC StopRPC)
(* Client functions)
(FNS ImportInterface RemoteBind UnimportInterface)
(* Server functions)
(FNS Binder NewExportTableEntry ExportInterface UnexportInterface)
(* Conversations)
(FNS \Authenticate StartConversation)
(* Basic protocol operation)
(FNS \RPCTopProc \RPCServerProc \RoutePup \ExchangePackets \DoSignal)
(* Call management)
(FNS \StartCall \Call \AbortRemote CantCatchHere \StartSignal \StartReturn)
(* Local id maintenance)
(FNS \SetWanting \ClearWanting \Wanting \NewHandleCnt \NewProcess \FindHandle \KillHandle)
(* encryption utilities)
(FNS \EncryptPup \DecryptPup)
(* Utilities)
(FNS \RPCOpenClosest \SetupResponse \ReceiveExtra \SendExtra CheapHopsToNet \CheckRPC
\RPCNotAliveErr \ServerError \InitRPCVars)
(DECLARE: DONTCOPY (MACROS FILLPUPSOURCE))
(* Authentication)
(FNS \ReplyToRFA \GetConnectionState)
(* Misc. constants)
(DECLARE: DONTCOPY (CONSTANTS (\RPCLupineArgStart 11)
(\RPCPupWordOvLen 10)
(\RPCPupByteOvLen 20)
(\RPCMaxDataOffset 264)
(\RPCMaxPupLength 550)
(\RPCRetransTimeout 1000)
(\RPCPingTimeout 5000)
(\RPCMaxPingTimeout 60000)
(\RPCMaxTransCount 14)
(\RPCTransTimeoutIncr 100)
(\RPCDelayPerHop 500)
(\NonceIdOffset 6)
(\RPCPktIDOffset 2)
(\RPCRFAcallerIDOffset 12)
(\PT.ECHOME 1)
(\PT.IAMECHO 2)
(\PUPOVLEN 22)
(\RPCStringHeaderLength 2)
(\RPCCheckLength 2)
(\RPCClearHeaderLength 2)
(\RPCRespCKBlocks 3))
(* State constants for \ExchangePackets)
(CONSTANTS (\stReceiving 'receiving)
(\stSending 'sending)
(\stCall 'call)
(\stEndCall 'endCall)
(\stAuthReq 'authReq))
(* constants for result field of pups)
(CONSTANTS (\rcResult 0)
(\rcUnbound 1)
(\rcSignal 2)
(\rcUnwind 3)
(\rcProtocol 4))
(* constants for type field of pups)
(CONSTANTS (\clCall 0)
(\clData 1)
(\clAck 2)
(\clRFA 4))
(* RPC internal error codes)
(CONSTANTS (\ecUnbound 'unbound)
(\ecTimeout 'timeout))
(* Authentication constants)
(CONSTANTS (\RPCAuthKyPos 0)
(\RPCAuthConvKeyPos 8)
(\RPCAuthTimePos 16)
(\RPCAuthNamePos 18)
(\RPCAuthFixedLength 18)
(\RPCAuthenticatorOffset 24)))
(* Global parameters)
(INITVARS (\RPCNullSeed (ARRAY 8 '(BITS 8)
0 0))
(\HandleCnt 0)
(\HandleOverflow)
(\ConnectionTimeout 6)
(\CheckConnectionsInterval 60000)
(\RPCConnections)
(\RPCConversations)
(\RPCLastConversation)
(\RPCHandles)
(\RPCWanting)
(\RPCDefaultSocket 30)
(\BinderDisp)
(\RPCConvID)
(\RPCDontBotherWithRFA)
(\RPCDebugWaitForever)
(\RPCNumberOfServers 0)
(\RPCMaxServers 5)
(\RPCMaxIdlers 3)
(\RPCIdlers)
(\RPCDebugServers)
(\RPCServerErrors)
(\RPCMaxServerErrors 25))
(RESOURCES \RPCScratchStream)
(GLOBALVARS \RPCNullSeed \HandleCnt \HandleOverflow \RPCConnections \RPCConversations
\RPCLastConversation \RPCHandles \RPCWanting \RPCDefaultSocket \BinderDisp
\CallCnt \RPCConvID \RPCDontBotherWithRFA \RPCDebugWaitForever
\RPCNumberOfServers \RPCMaxServers \RPCMaxIdlers \RPCIdlers \ConnectionTimeout
\CheckConnectionsInterval \RPCDebugServers \RPCServerErrors \RPCMaxServerErrors)
(GLOBALVARS ExportTable \RPCTopProc \RPCSocket \RPCSocketNumber ExportCount)
(* The block records here reflect Andrew's layout of the transport mechanism in
{INDIGO}<CEDAR>RPC>RPCPkt.mesa and should track any changes made there)
(DECLARE: DONTCOPY
(RECORDS Connection Conversation ConversationID DispDetails ExportTableEntry
ImportInstance InterfaceName PktConversationID RPCBinderArgs RPCHandle
RPCPup RPCPupContents RPCRFAResponse RPCRFARequest VersionRange))
(VARS (\NoDispatcher 0)
(\MatchAnyVersion)
(\NoDispDetails))
(P (\InitRPCVars))
(GLOBALVARS \NoDispatcher \MatchAnyVersion \NoDispDetails)
(* adding stuff to pups)
(FNS \PutBinderString \AddRPCDispDetails \AddRPCVersion \AddPupDblWord \AddPupWord
\AddPupEnum \AddPupSmallp \AddPupBoolean \MarshalStream \MarshalArb \MarshalString
\MarshalAtom \MoveToPup \MoveToMultPups)
(* Picking stuff out of pups)
(FNS \GetBinderString \GetArgDisp \GetArgVersion \GetArgDblWord \GetArgWord \GetArgEnum
\GetArgBool \GetArgSmallp \UnmarshalString \UnmarshalStream \UnmarshalArb \UnmarshalAtom
\MoveFromPup \MoveFromMultPups \IncrDataOffset \IncrPupLength \CurrentPupBase
\CurrentPupPosition \CheckPupOverflow \CheckPupExhausted \SkipBytesOut \SkipWordsIn)
(* to control how much PUPTRACEFLG shows)
(ALISTS (PUPPRINTMACROS 96 97 98 104 105 106 120 100 108 121))
[VARS RPCPUPTYPES [PUPTYPES (UNION RPCPUPTYPES (LISTP (EVALV 'PUPTYPES]
(PUPONLYTYPES (UNION PUPONLYTYPES (MAPCAR RPCPUPTYPES (FUNCTION CADR]
(DECLARE: DONTCOPY (MACROS PUPDEBUGGING))
(DECLARE: DONTCOPY EVAL@COMPILE (P (RESETSAVE DWIMIFYCOMPFLG T)))
(FILES GRAPEVINE SIGNAL CRYPT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
CRYPT SIGNAL NOBOX ETHERRECORDS
(IMPORT)
LLCHAR LLARRAYELT))))
(* Top Level functions)
(DEFINEQ
(InitRPC
[LAMBDA (socket) (* ht: "27-Sep-84 08:56")
(* Start listening and initialise state of RPC world)
(PROG NIL
(if (THIS.PROCESS)=NIL
then (printout T T "Please enable processes by typing (PROCESSWORLD) and try again" T)
(RETURN))
(\RPCSocketNumber←(OR socket \RPCDefaultSocket))
(if (OR \RPCSocket←(OPENPUPSOCKET \RPCSocketNumber 'FAIL)=NIL (FIND.PROCESS \RPCTopProc))
then (\RPCSocket←(OPENPUPSOCKET \RPCSocketNumber 'ACCEPT))
(SELECTQ (ASKUSER DWIMWAIT 'Y
"OK to Reinitialize? ")
(Y (StopRPC)
\RPCSocket←
(OPENPUPSOCKET \RPCSocketNumber))
(N (RETURN))
(SHOULDNT)))
[\RPCTopProc←(PROCESS.NAME (ADD.PROCESS '(\RPCTopProc)]
(ExportTable←NIL)
(ExportCount←-1)
(\RPCConnections←NIL)
(\RPCConversations←NIL)
[\RPCLastConversation←(create ConversationID
originatorC ←(ETHERHOSTNUMBER)
count ←(IBOX (CLOCK 0]
(* * cheat to make sure that bit is 0 for later use as PktConversationID)
(\RPCLastConversation:count:originatorP←0)
(\RPCHandles←NIL)
(\RPCWanting←NIL)
(\RPCIdlers←NIL)
(\HandleCnt←0)
(\HandleOverflow←NIL)
(\CallCnt←0)
(for i from 1 to \RPCMaxIdlers
do (ADD.PROCESS '(\RPCServerProc))
(BLOCK))
(\RPCNumberOfServers←\RPCMaxIdlers)
(\RPCConvID←(LOGAND -32769 (CLOCK))) (* mask out the "caller" bit)
(NewExportTableEntry (FUNCTION Binder)
(create InterfaceName
type ← "Binder"))
(ExportTable:1:dispId←\NoDispatcher+1) (* all of this adds up to the binder having hint 0 and
id 1)
(\BinderDisp←(create DispDetails
dId ←(\NoDispatcher+1)))
(RETURN T])
(StopRPC
[LAMBDA NIL (* ht: " 4-SEP-83 17:52")
\BinderDisp←NIL (* so we can tell if we're alive or dead)
(if (FIND.PROCESS \RPCTopProc)
then (DEL.PROCESS \RPCTopProc))
(NLSETQ (CLOSEPUPSOCKET \RPCSocket))
(MAP.PROCESSES (FUNCTION (LAMBDA (p n f)
(if f:1=(QUOTE \RPCServerProc)
then (DEL.PROCESS p])
)
(* Client functions)
(DEFINEQ
(ImportInterface
[LAMBDA (type instance version stubProt) (* ht: " 3-Jan-85 13:37")
(* = RPCBinding.ImportInterface, .TryBinding)
(\CheckRPC)
(PROG (host socket)
(if (AND instance instance~= 'BROADCAST)
then (if (STRPOS "." instance)
then (* an rName)
(if ~(STRINGP host←(GV.READCONNECT instance))
then (Signal 'ImportFailed 'BadRName))
elseif host←(ETHERPORT instance)
else (Signal 'ImportFailed 'BadInstance))
socket←(ETHERPORT host)
elseif socket←(\RPCOpenClosest (if instance= 'BROADCAST
then (ETHERPORT 0 T T)
elseif (STRPOS "." type)
then (* an rName of a group, we hope)
(LOCATESOCKETS type T)
elseif (ETHERPORT type T T)
else (Signal 'ImportFailed 'BadType))
type)
else (SHOULDNT))
(RETURN (create ImportInstance
host ← socket
dispDetails ← (enable
CallFailed => (goto die)
(RemoteBind socket type (if instance= 'BROADCAST
then NIL
else instance)
(OR stubProt \MatchAnyVersion)
(OR version \MatchAnyVersion))
die -> (Signal 'ImportFailed 'communications))])
(RemoteBind
[LAMBDA (socket type instance stubProt version) (* ht: " 1-Aug-85 08:56")
(PROG (l..cPup contents expStubProt expVersion disp)
(DECLARE (SPECVARS l..cPup))
(l..cPup←(\StartCall socket \BinderDisp))
(contents←l..cPup:PUPCONTENTS)
(contents:request←0)
(add l..cPup:PUPLENGTH 6)
(contents:bindType←(LRSH l..cPup:PUPLENGTH-\RPCPupByteOvLen-\PUPOVLEN 1))
(contents:bindInstance←(\PutBinderString l..cPup type))
(\PutBinderString l..cPup instance)
(l..cPup←(\Call l..cPup))
(expStubProt←(\GetArgVersion l..cPup))
(expVersion←(\GetArgVersion l..cPup))
(disp←(\GetArgDisp l..cPup))
(if disp:dId=\NoDispatcher
then (Signal 'ImportFailed
'unbound))
(if (AND (NOT (EQUAL stubProt \MatchAnyVersion))
(NOT (EQUAL expStubProt \MatchAnyVersion))
(OR (IGREATERP stubProt:first expStubProt:last)
(ILESSP stubProt:last expStubProt:first)))
then (Signal 'ImportFailed
'stubProtocol))
(if (AND (NOT (EQUAL version \MatchAnyVersion))
(IGREATERP version:first version:last))
then (Signal 'ImportFailed
'badVersion))
(if (AND (NOT (EQUAL version \MatchAnyVersion))
(NOT (EQUAL expVersion \MatchAnyVersion))
(OR (IGREATERP version:first expVersion:last)
(ILESSP version:last expVersion:first)))
then (Signal 'ImportFailed
'wrongVersion))
(RELEASE.PUP l..cPup)
(RETURN disp])
(UnimportInterface
[LAMBDA (interface) (* ht: "13-JAN-83 10:52")
(* ht: "13-JAN-83 09:46")
])
)
(* Server functions)
(DEFINEQ
(Binder
[LAMBDA (pup) (* ht: "11-Feb-84 10:44")
(if pup:PUPCONTENTS:request=0
then (PROG ((contents (pup:PUPCONTENTS))
type instance ete (stubProt \MatchAnyVersion)
(version \MatchAnyVersion)
(dispatcher \NoDispDetails))
(type←(\GetBinderString contents contents:bindType contents:bindInstance))
(instance←(\GetBinderString contents contents:bindInstance (LRSH
pup:PUPLENGTH-\RPCPupByteOvLen-\PUPOVLEN 1)))
(if ete←[for e in ExportTable unless e:dispId=\NoDispatcher
thereis (AND (OR type=NIL (STREQUAL type e:intName:type))
(OR instance=NIL (STREQUAL instance e:intName:instance]
then (stubProt←ete:stubProt)
(version←ete:intName:version)
(dispatcher←(create DispDetails
dMds ← ete:mds
dId ← ete:dispId
hint ← ete:dispHint)))
(* set up response packet)
(pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen))
(\AddRPCVersion pup stubProt)
(\AddRPCVersion pup version)
(\AddRPCDispDetails pup dispatcher)
(RETURN pup))
elseif pup:PUPCONTENTS:request=1
then (* client wishes to abort a server process)
(PROG ((sourcePSB (\GetArgSmallp pup))
(localId (\GetArgSmallp pup))
(convId (\GetArgDblWord pup))
(callCnt (\GetArgDblWord pup))
handle)
(if (AND handle←(ASSOC localId \RPCHandles)
(CAR (PROCESSPROP handle:process (QUOTE FORM)))=(QUOTE \RPCServerProc))
then (PROCESS.APPLY handle:process (FUNCTION Signal)
<(QUOTE RPCAbortMe?)
< pup:SOURCE sourcePSB convId callCnt>>))
(\StartReturn pup)
(RETURN pup))
else (ERROR "wrong request to binder" pup:PUPCONTENTS:request])
(NewExportTableEntry
[LAMBDA (dispatcher intName stubProt mds) (* ht: " 1-SEP-83 16:02")
(CAR (push ExportTable (create ExportTableEntry
dispHint ←(do (OR (SMALLP (add ExportCount 1))
ExportCount←1)
repeatwhile (ASSOC ExportCount ExportTable)
finally (RETURN ExportCount))
dispId ←(CLOCK)
dispatcher ← dispatcher
mds ←(OR mds 0)
intName ←(create InterfaceName
type ←(MKSTRING intName:type)
instance ←(MKSTRING intName:instance)
version ← intName:version)
stubProt ←(OR stubProt \MatchAnyVersion])
(ExportInterface
[LAMBDA (name pw type instance version dispatcher stubProt)
(* bvm: "19-Jul-85 18:00")
(\CheckRPC)
(MakeErrorsSignals)
[PROG ((me (ETHERHOSTNUMBER))
current res) (* interface.instance had better name us one way or
another)
[COND
[(STRPOS "." instance) (* an rName)
[COND
([NOT (STRINGP (SETQ current (GV.READCONNECT instance]
(Signal (QUOTE ExportFailed)
(QUOTE BadRName]
(COND
((NEQ me (CAR (ETHERPORT current)))
(SELECTQ (GV.CHANGECONNECT instance (PORTSTRING me)
(OR name T)
pw)
(T)
(Signal (QUOTE ExportFailed)
(QUOTE BadInstance]
((NEQ (CAR (ETHERPORT instance))
me)
(Signal (QUOTE ExportFailed)
(QUOTE WrongInstance]
(COND
((STRPOS "." type) (* an rName -
we should be among the members)
(COND
((NOT (for m in [CDR (OR (LISTP (SETQ res (GV.READMEMBERS type)))
(Signal (QUOTE ExportFailed)
(QUOTE BadRName]
thereis (STREQUAL instance m)))
(COND
((NEQ (SETQ res (GV.ADDMEMBER type instance))
T)
(Signal (QUOTE ExportFailed)
res]
(NewExportTableEntry dispatcher (create InterfaceName
type ← type
instance ← instance
version ←(OR version \MatchAnyVersion))
stubProt])
(UnexportInterface
[LAMBDA (etEntry) (* ht: "22-JAN-83 14:30")
(SETQ ExportTable (DREMOVE etEntry ExportTable])
)
(* Conversations)
(DEFINEQ
(\Authenticate
[LAMBDA (caller key callee) (* ht: "26-Sep-84 19:53")
(* key must either be a key already, or a LISP-locally
encrypted password, e.g. the result of a call to
\INTERNAL/GETPASSWORD)
([LAMBDA (res)
(if res~=T
then (Signal 'AuthenticateFailed
<caller key res>]
(GV.AUTHENTICATE caller key))
([LAMBDA (res)
(if ~(TYPENAMEP res 'TIMESTAMP)
then (Signal 'AuthenticateFailed
<callee res>]
(GV.CHECKSTAMP callee))
(PROG ((nameLen (((NCHARS caller)+ 1)/2))
(iv (GetRandomIV))
(kb (CorrectParity (COPYARRAY DESNullKey)))
(ky (GetRandomCryptKey))
(convKey (GetRandomCryptKey))
nBlks auth)
(nBlks←(\RPCAuthFixedLength+\RPCStringHeaderLength+nameLen+\DESBlockSize-1)/\DESBlockSize)
(auth←(ARRAY nBlks*\DESBlockSize '(BITS 16)
0 0))
(\BLT (\ADDBASE auth:ARRAYP.BASE \RPCAuthKyPos)
ky:ARRAYP.BASE 4)
(\BLT (\ADDBASE auth:ARRAYP.BASE \RPCAuthConvKeyPos)
convKey:ARRAYP.BASE 4)
(* * time is already 0)
((ELT auth \RPCAuthNamePos)←(NCHARS caller))
(\PUTBASESTRING auth:ARRAYP.BASE (CONSTANT (LLSH \RPCAuthNamePos+\RPCStringHeaderLength 1))
caller)
(EncryptBlock kb (\ADDBASE auth:ARRAYP.BASE \RPCAuthConvKeyPos)
(\ADDBASE auth:ARRAYP.BASE \RPCAuthConvKeyPos))
(CryptData ky nBlks-2 (\ADDBASE auth:ARRAYP.BASE \RPCAuthConvKeyPos)
(\ADDBASE auth:ARRAYP.BASE \RPCAuthConvKeyPos)
'encrypt
'cbcCheck
\RPCNullSeed)
(EncryptBlock kb (\ADDBASE auth:ARRAYP.BASE \RPCAuthKyPos)
(\ADDBASE auth:ARRAYP.BASE \RPCAuthKyPos))
(RETURN (create Conversation
authenticator ← auth
convKey ← convKey
iv ← iv])
(StartConversation
[LAMBDA (caller key callee level) (* ht: " 3-Jan-85 13:32")
(* key must either be a key already, or a LISP-locally
encrypted password, e.g. the result of a call to
\INTERNAL/GETPASSWORD)
(if level~=%'CBCCheck
then (Signal 'NotImplemented level))
(PROG ((conv (\Authenticate caller key callee)))
(conv:caller←caller)
(conv:callee←callee)
(conv:level←level)
(add \RPCLastConversation:count:ls 1)
(if (IEQP \RPCLastConversation:count:ls 0)
then (add \RPCLastConversation:count:ms 1))
(conv:cId←(create ConversationID
count ←(IBOX \RPCLastConversation:count)
originatorC ← \RPCLastConversation:originatorC))
(push \RPCConversations conv)
(RETURN conv])
)
(* Basic protocol operation)
(DEFINEQ
(\RPCTopProc
[LAMBDA NIL (* ht: "27-Sep-84 08:17")
(* the root process in a server. Handles EchoMe pups for establishing connections, and also dispatches RPC pups to
the appropriate process. Note that pup is shared among all processes, so they have to be careful with it.
Also checks periodically to age idle connections and kill them if they get too old.)
(PROG (pup timer tString)
(while pup←(GETPUP \RPCSocket) do (RELEASE.PUP pup))
(timer←(SETUPTIMER \CheckConnectionsInterval)) (* NO LONGER NEEDED (OR (if \RPCPupQueue then
(pup←\RPCPupQueue) (\RPCPupQueue←pup:ETHERPACKET.EPLINK
) (pup:ETHERPACKET.EPLINK←NIL) T)))
LP (if pup←(GETPUP \RPCSocket (LRSH \CheckConnectionsInterval 4))
then (SELECTC (fetch PUPTYPE of pup)
(\PT.ECHOME (SETQ tString (GETPUPSTRING pup 0))
(if [for e in ExportTable
unless (EQ (fetch dispId of e)
\NoDispatcher)
thereis (STREQUAL tString
(fetch type
of (fetch intName of e]
then (SETUPPUP pup (fetch SOURCE of pup)
(fetch SOURCESKT of pup)
\PT.IAMECHO
(fetch PUPID of pup)
\RPCSocket)
(FILLPUPSOURCE pup)
(SENDPUP \RPCSocket pup))
(RELEASE.PUP pup))
(if (fetch RPCP of pup)
then (\RoutePup pup)
else (PUPDEBUGGING T "ignoring non-RPC pup")
(RELEASE.PUP pup)))
elseif (TIMEREXPIRED? timer)
then (* check the vacant connections for moribund ones)
(SETQ \RPCConnections (for c in \RPCConnections
when (AND (add (fetch age of c)
1)
(ILEQ (fetch age of c)
\ConnectionTimeout))
collect c))
(\RPCHandles←(for h in \RPCHandles when (PROCESSP h:process) collect h))
(timer←(SETUPTIMER \CheckConnectionsInterval timer)))
(GO LP])
(\RPCServerProc
[LAMBDA (pup) (* ht: " 2-Aug-85 09:38")
(* At least one of these is running for each connection
being supported by a server)
(PROG (handle localId event)
(handle←(\NewProcess T))
(localId←handle:localId)
(event←handle:event)
(* * this prog here just to protect the server)
TopLp
(NLSETQ (PROG (expInst RPCConnection RPCCallCount conv decrypted)
(if (NOT pup)
then (GO WAIT))
TOPLP
(decrypted←NIL)
(if RPCConnection←(for c in \RPCConnections
thereis
(* note that the first term of the AND means we will never find a conv. we started -
packets for them had better be being waited for)
(AND c:remoteHost=pup:SOURCE
c:activity=pup:sourcePSB (IEQP c:convId
pup:PUPCONTENTS:conversationID)))
then (if conv←RPCConnection:conv
then (if (NOT (\DecryptPup pup conv))
then (PUPDEBUGGING T "decryption failed")
(GO BAD)))
(decrypted←T)
(if pup:PUPCONTENTS:callAgent~=pup:sourcePSB
then (* phooey)
(PUPDEBUGGING T "source/callAgent mismatch")
(GO BAD))
(if (AND pup:class=\clCall (IGREATERP pup:PUPCONTENTS:callCount
RPCConnection:callCnt))
then (if pup:PUPCONTENTS:packetSeq~=1
then (PUPDEBUGGING T "non-1 packetSeq")
(GO BAD))
(* genuine new call)
else (GO OLD))
elseif pup:class=\clCall
then (* need a new RPCConnection)
(if conv← (enable
CallFailed => (PUPDEBUGGING T "can't get Conn state")
(exit)
(\GetConnectionState pup))
then (if conv=T
then conv←NIL)
(* GCS will have done any necessary decryption)
(push \RPCConnections
(RPCConnection←(create Connection
conv ← conv
convId ←
pup:PUPCONTENTS:conversationID
remoteHost ← pup:SOURCE
activity ←
pup:PUPCONTENTS:callAgent
callCnt ← -1)))
else (GO BAD))
else (GO OLD))
LP (RPCConnection:age←0)
(RPCConnection:processId←localId)
(RPCConnection:callCnt←RPCCallCount←pup:PUPCONTENTS:callCount)
(* turn the pup around)
(\SetupResponse pup)
(if pup:EOM
then (pup:PUPCONTENTS:MDSBase←\rcResult)
(* note we overwrite the MDSBase hint here, but as we
don%'t use it it doesn%'t matter))
(if (AND expInst←(ASSOC pup:PUPCONTENTS:dispatcherHint ExportTable)
(IEQP expInst:dispId pup:PUPCONTENTS:dispatcherId))
then (pup:dataOffset←\RPCLupineArgStart)
(enable
unwindRequested => (goto uw)
CallFailed => (PUPDEBUGGING T "Call Failed " arg)
(goto lp)
LispError => (if \RPCDebugServers
then (reject)
else (\ServerError arg RPCConnection)
(goto lp))
RPCAbortMe? => (if (AND RPCConnection:remoteHost=arg:1
RPCConnection:activity=arg:2
(IEQP RPCConnection:convId arg:3)
(IEQP RPCCallCount arg:4))
then (goto lp)
else (sresume T))
(pup←(APPLY* expInst:dispatcher pup pup:PUPCONTENTS:request conv))
uw -> (pup←$SignalArg$)
(\SetupResponse pup)
(pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen))
(pup:PUPCONTENTS:MDSBase←\rcResult)
lp -> (pup←NIL))
else (pup:PUPCONTENTS:MDSBase←\rcUnbound)
(pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen)))
(if pup
then pup← (enable
LispError => (if \RPCDebugServers
then (reject)
else (\ServerError arg \RPCConnections)
(exit))
CallFailed => (* NIL into pup)
(exit)
(\ExchangePackets pup \stEndCall NIL conv)))
(if pup
then (GO LP))
WAIT (* Exchange left us nothing to go on with)
(handle←(\FindHandle (THIS.PROCESS)))
(\ClearWanting handle) (* just in case)
(if (ILESSP (LENGTH \RPCIdlers)
\RPCMaxIdlers)
then (push \RPCIdlers handle)
(until pup←handle:newPup do (AWAIT.EVENT event))
(* wait to be pressed into service again)
(handle:newPup←NIL)
(GO TOPLP)
else (add \RPCNumberOfServers -1)
(\KillHandle handle)
(PROCESS.RETURN))
OLD (* old -
actually other cases exist -
should be checked and errors raised)
(if (AND RPCConnection pup:destPSB~=0 pup:destPSB~=RPCConnection:processId)
then (* genuine bad hint)
(if ~decrypted
then (SHOULDNT "not decrypted OLD??")
elseif conv
then (\EncryptPup pup conv)
(* !))
(\RoutePup pup T)
(pup←NIL)
(GO WAIT))
(if [AND pup:EOM pup:ack (OR pup:class=\clData
(if handle←(ASSOC pup:destPSB \RPCHandles)
then (AND (NOT (\Wanting pup:destPSB))
(NOT (FMEMB handle:process
\RPCIdlers))
handle:process~=(THIS.PROCESS))
elseif (AND pup:destPSB=0 RPCConnection)
then (pup:destPSB←RPCConnection:processId)
(if ~decrypted
then (SHOULDNT
"not decrypted OLD??2")
elseif conv
then (\EncryptPup pup conv)
(* !))
(\RoutePup pup)
(pup←NIL)
(GO WAIT]
then (\SetupResponse pup)
(pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen))
(pup:sourcePSB←(if handle
then handle:localId
else 0))
(FILLPUPSOURCE pup)
(pup:class←\clAck)
(pup:EOM←T)
(pup:ack←NIL)
(if (AND decrypted conv)
then (\EncryptPup pup conv))
(SENDPUP \RPCSocket pup)
else (PUPDEBUGGING T "throwing away stale packet"))
BAD (RELEASE.PUP pup)
(pup←NIL)
(GO WAIT)))
(pup←NIL)
(GO TopLp])
(\RoutePup
[LAMBDA (pup badHint) (* ht: "27-Sep-84 09:11")
(PROG (handle)
(if (AND ~badHint handle←(\Wanting pup:destPSB))
then (* try the hint)
(\ClearWanting handle)
(handle:newPup←pup)
(NOTIFY.EVENT handle:event T)
else (if badHint
then (pup:destPSB←0))
(if handle←(pop \RPCIdlers)
then (handle:newPup←pup)
(NOTIFY.EVENT handle:event T)
elseif (ILESSP \RPCNumberOfServers \RPCMaxServers)
then (add \RPCNumberOfServers 1)
(ADD.PROCESS < '\RPCServerProc
pup>)
else (RELEASE.PUP pup)
(PUPDEBUGGING T "No room for new server - ignoring call")
(RETURN))
(BLOCK) (* Let it get started)])
(\ExchangePackets
[LAMBDA (pup state signalDispatcher conv) (* ht: "28-Sep-84 02:25")
(* = RPCPktIO.PktExchange)
(PROG (newPup acked (handle (\FindHandle (THIS.PROCESS)))
transCount transTimeout pingTimeout callCount pktSeq callAgent)
RLP (pingTimeout←\RPCPingTimeout)
(transCount←0)
(transTimeout←\RPCRetransTimeout+\RPCDelayPerHop*(CheapHopsToNet pup:DESTNET))
(FILLPUPSOURCE pup)
(pup:sourcePSB←handle:localId)
(if pup:PUPCONTENTS:packetSeq=0
then (* new call)
(SELECTC state
(\stCall (PUPDEBUGGING ",20a")
(replace class of pup with \clCall)
(replace EOM of pup with T)
(replace ack of pup with NIL))
(\stSending (PUPDEBUGGING ",20b")
(replace class of pup with \clCall)
(replace EOM of pup with NIL)
(replace ack of pup with T))
(\stAuthReq (PUPDEBUGGING ",20c")
(replace class of pup with \clRFA)
(replace EOM of pup with T)
(replace ack of pup with NIL))
(SHOULDNT '1a))
(pup:PUPCONTENTS:callCount←(add \CallCnt 1))
(pup:PUPCONTENTS:packetSeq←1)
else (SELECTC state
(\stEndCall (* (PUPDEBUGGING "," 11))
(replace class of pup with \clData)
(replace EOM of pup with T)
(replace ack of pup with NIL))
(\stReceiving (replace class of pup with \clAck)
(PUPDEBUGGING ",11a")
(replace EOM of pup with T)
(replace ack of pup with NIL)
(SETQ acked T))
(\stCall (PUPDEBUGGING ",11b")
(replace class of pup with \clData)
(replace EOM of pup with T)
(replace ack of pup with NIL))
(\stSending (PUPDEBUGGING ",11c")
(replace class of pup with \clData)
(replace EOM of pup with NIL)
(replace ack of pup with T))
(SHOULDNT 1))
(if state~=\stReceiving
then (add pup:PUPCONTENTS:packetSeq 1)))
(callCount←pup:PUPCONTENTS:callCount)
(pktSeq←pup:PUPCONTENTS:packetSeq)
(callAgent←pup:PUPCONTENTS:callAgent)
(\SetWanting handle)
PingTrans
(if conv
then (\EncryptPup pup conv))
Retrans
(SENDPUP \RPCSocket pup)
LP (if newPup←handle:newPup
elseif (AWAIT.EVENT handle:event (if acked
then pingTimeout
else transTimeout))=PSTAT.TIMEDOUT
then (if \RPCDebugWaitForever
then (GO LP)
else (if acked
then (pup:class←\clAck)
(pup:ack←T)
(pup:EOM←T)
(pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen))
(pingTimeout←(MIN \RPCMaxPingTimeout (LLSH pingTimeout 1)))
(acked←NIL)
(GO PingTrans)
else (pup:ack←T)
(if (IGREATERP (add transCount 1)
\RPCMaxTransCount)
then (RELEASE.PUP pup)
(Signal 'CallFailed
\ecTimeout))
(transTimeout←transTimeout+\RPCTransTimeoutIncr)
(GO Retrans) (* wait for someone to give us a pup)))
else (GO LP))
(handle:newPup←NIL)
(if newPup:class=\clRFA
then (\ReplyToRFA pup newPup conv callAgent callCount)
(\SetWanting handle)
(GO LP))
(if (AND conv (IEQP pup:PUPCONTENTS:conversationID newPup:PUPCONTENTS:conversationID)
newPup:SOURCE=pup:DEST)
then
(* * we don%'t check for success, as e.g. ack packets will not have correct checksum)
(\DecryptPup newPup conv))
(if (AND (IEQP pup:PUPCONTENTS:conversationID newPup:PUPCONTENTS:conversationID)
newPup:SOURCE=pup:DEST newPup:PUPCONTENTS:callAgent=callAgent)
then (* (PUPDEBUGGING "," 4))
(* related to us)
(if (IEQP newPup:PUPCONTENTS:callCount callCount)
then (PUPDEBUGGING "," "5") (* our call)
(if pktSeq+1=newPup:PUPCONTENTS:packetSeq
then (PUPDEBUGGING "," "6")
(* next in line)
(SELECTC state
((LIST \stSending \stEndCall)
(SHOULDNT 2))
((LIST \stCall \stReceiving \stAuthReq)
(PUPDEBUGGING "," "12")
(SELECTC (fetch class of newPup)
(\clData (PUPDEBUGGING "," "14"))
(\clAck (SETQ acked T)
(RELEASE.PUP newPup)
(\SetWanting handle)
(GO LP))
((LIST \clCall \clRFA)
(PUPDEBUGGING "," "15")
(SHOULDNT 3))
(SHOULDNT 4)))
(SHOULDNT 6))
elseif pktSeq=newPup:PUPCONTENTS:packetSeq
then (PUPDEBUGGING "," "7")
(* same as us)
(SELECTC (fetch class of newPup)
[\clAck (PUPDEBUGGING "," "16")
(if (EQ (fetch class of pup)
\clCall)
then (replace destPSB of pup
with (fetch sourcePSB of newPup))
(* update hint as this pup gets reused in multipkt
calls)
)
(SETQ acked T)
(SELECTC state
((LIST \stSending \stEndCall)
(PUPDEBUGGING "," "16a")
(RELEASE.PUP newPup)
(SETQ newPup)
(* fall out empty-handed)
)
(PROGN (PUPDEBUGGING ",16b")
(* call, authReq, or receiving -
just discard and wait, someone else is working on it)
(RELEASE.PUP newPup)
(\SetWanting handle)
(GO LP]
((LIST \clData \clCall)
(* retransmission)
(PUPDEBUGGING ",7a")
(SELECTC state
(\stReceiving (PUPDEBUGGING ",7a1")
(if (fetch ack of newPup)
then (PUPDEBUGGING ",7a1a")
(RELEASE.PUP newPup)
(\SetWanting handle)
(GO Retrans)
else (PUPDEBUGGING ",7a1b")
(RELEASE.PUP newPup)
(\SetWanting handle)
(GO LP)))
(SHOULDNT 8)))
(\clRFA (SHOULDNT 9))
(SHOULDNT 10))
elseif (ILESSP newPup:PUPCONTENTS:packetSeq pktSeq)
then (PUPDEBUGGING "," "8")
(* earlier, discard)
(RELEASE.PUP newPup)
(\SetWanting handle)
(GO LP)
else (PUPDEBUGGING "," "1") (* future)
(SHOULDNT 11))
elseif (AND (IGREATERP newPup:PUPCONTENTS:callCount callCount)
state=\stEndCall)
then (* (PUPDEBUGGING "," 9))
(if newPup:class~=\clCall
then (PUPDEBUGGING "," "10")
(SHOULDNT 12))
else (PUPDEBUGGING "," "2") (* shouldn%'t have come to us -
wrong call)
(\RoutePup newPup T)
(\SetWanting handle)
(GO LP))
else (PUPDEBUGGING "," "3") (* shouldn%'t have come to us -
wrong conversation or remoteId)
(\RoutePup newPup T)
(\SetWanting handle)
(GO LP))
(if newPup
then (RELEASE.PUP pup) (* this is right for \stSending, not sure about
\endCall)
(if (AND newPup:PUPCONTENTS:MDSBase=\rcSignal state=\stCall signalDispatcher)
then (pup←(\DoSignal signalDispatcher newPup conv))
(GO RLP))
(RETURN newPup)
else (if conv
then (* better fix up pup in case it gets reused -
e.g. in \SendExtra)
(pup:PUPCONTENTS:callCount←callCount)
(pup:PUPCONTENTS:packetSeq←pktSeq)
(pup:PUPCONTENTS:callAgent←callAgent))
(RETURN])
(\DoSignal
[LAMBDA (disp pup conv) (* ht: "27-Sep-84 22:47")
(* to allow us to be pinged if nec.)
(\SetupResponse pup)
(if pup:EOM
then (pup:PUPCONTENTS:MDSBase←\rcResult))
pup:dataOffset←\RPCPupWordOvLen
(enable
unwindRequested => (* not at all sure about this)
(exit)
(pup←(APPLY* disp pup conv))
unwind -> (pup:PUPCONTENTS:MDSBase←\rcUnwind)
(pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen))
(pup←(\ExchangePackets pup \stCall (FUNCTION CantCatchHere)
conv))
(SELECTC (fetch MDSBase of (fetch PUPCONTENTS of pup))
(\rcResult)
(\rcSignal (SHOULDNT 21))
(SHOULDNT 22)))
pup])
)
(* Call management)
(DEFINEQ
(\StartCall
[LAMBDA (socket disp conv) (* ht: "27-Jul-85 14:45")
(\CheckRPC)
(if (NOT socket)
then (Signal 'CallFailed
'Unimported))
(PROG ((pup (ALLOCATE.PUP))
(handle (\NewProcess))
id)
(SETUPPUP pup socket \RPCSocketNumber 96 0 \RPCSocket)
(\SetupResponse pup (if conv
then (id←conv:cId)
(if (IEQP id:originatorC (ETHERHOSTNUMBER))
then (* cheat for efficiency -
set originatorP bit to 0)
(LOGAND id:count (CONSTANT (LOGXOR -1 32768)))
elseif (IEQP id:originatorC handle:remoteId)
then (* cheat for efficiency -
set originatorP bit to 1)
(LOGOR id:count (CONSTANT 32768))
else (Signal 'MisusedConversation))
else \RPCConvID)
handle:localId handle:remoteId)
(pup:PUPCONTENTS:packetSeq←0)
(pup:PUPCONTENTS:MDSBase←disp:dMds)
(pup:PUPCONTENTS:dispatcherHint←disp:hint)
(pup:PUPCONTENTS:dispatcherId←disp:dId)
(pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen))
(RETURN pup])
(\Call
[LAMBDA (pup signalDispatcher conv) (* ht: " 8-Apr-85 07:58")
pup←
(enable
AbortRemote => (\AbortRemote pup:DEST pup:sourcePSB pup:PUPCONTENTS:conversationID
[if pup:destPSB~=0
then pup:destPSB
else (fetch remoteId of (\FindHandle (THIS.PROCESS]
pup:PUPCONTENTS:callCount conv)
(\RELEASE.PUP pup)
(goto aborted)
(\ExchangePackets pup \stCall signalDispatcher conv)
aborted -> (ERROR!))
(replace remoteId of (\FindHandle (THIS.PROCESS)) with pup:sourcePSB)
(\SetupResponse pup)
(SELECTC (fetch MDSBase of (fetch PUPCONTENTS of pup))
(\rcResult (replace dataOffset of pup with \RPCPupWordOvLen)
pup)
(\rcUnwind (Signal 'unwindRequested
pup))
(\rcUnbound (Signal 'CallFailed
\ecUnbound))
(SHOULDNT])
(\AbortRemote
[LAMBDA (host src id remid callCnt conv) (* ht: " 8-Apr-85 07:16")
(PROG (pup)
(pup←(\StartCall host \BinderDisp conv))
(\AddPupWord pup 1) (* remote abort call index)
(\AddPupSmallp pup src)
(\AddPupSmallp pup remid)
(\AddPupDblWord pup id)
(\AddPupDblWord pup callCnt)
(enable
CallFailed => (printout T T "Attempt to abort remote process failed" T)
(exit)
(\RELEASE.PUP (\Call pup (FUNCTION CantCatchHere)
conv)))])
(CantCatchHere
[LAMBDA (l..cPup) (* ht: " 1-Aug-85 08:56")
(HELP])
(\StartSignal
[LAMBDA (pup) (* ht: " 5-SEP-83 14:37")
pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen)
pup:PUPCONTENTS:MDSBase←\rcSignal])
(\StartReturn
[LAMBDA (pup) (* ht: " 4-SEP-83 18:23")
(* Should really be a macro, but the stubs won't have
access to the PUP record)
pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen])
)
(* Local id maintenance)
(DEFINEQ
(\SetWanting
[LAMBDA (handle) (* ht: " 5-SEP-83 08:07")
(push \RPCWanting handle])
(\ClearWanting
[LAMBDA (handle) (* ht: " 5-SEP-83 08:07")
\RPCWanting←(DREMOVE handle \RPCWanting])
(\Wanting
[LAMBDA (hint) (* ht: " 5-SEP-83 08:08")
(FASSOC hint \RPCWanting])
(\NewHandleCnt
[LAMBDA NIL (* ht: " 1-SEP-83 16:30")
(do (if ~(SMALLP (add \HandleCnt 1))
then (\HandleCnt←1)
(\HandleOverflow←T))
repeatwhile (AND \HandleOverflow (ASSOC \HandleCnt \RPCHandles)))
\HandleCnt])
(\NewProcess
[LAMBDA (newFlg) (* ht: "27-Sep-84 09:32")
(PROG (process)
(process←(THIS.PROCESS))
(RETURN (if (AND ~newFlg (\FindHandle process))
else (CAR (push \RPCHandles (create RPCHandle
localId ←(\NewHandleCnt)
event ←(CREATE.EVENT (PACK* 'Server
\HandleCnt))
remoteId ← 0
process ← process])
(\FindHandle
[LAMBDA (process) (* ht: " 4-SEP-83 18:45")
(thereis h in \RPCHandles suchthat (EQ (fetch process of h)
process])
(\KillHandle
[LAMBDA (h) (* ht: " 8-Apr-85 09:00")
(if h
then \RPCHandles←(DREMOVE h \RPCHandles])
)
(* encryption utilities)
(DEFINEQ
(\EncryptPup
[LAMBDA (pup conv) (* ht: "28-Sep-84 01:13")
(* if we ever get here with an odd PUPLENGTH,
disaster!)
(PROG ((words ((LRSH pup:PUPLENGTH-\PUPOVLEN 1)+(CONSTANT \RPCCheckLength-\RPCClearHeaderLength)))
nBlks check (cryptBase (\ADDBASE pup:PUPCONTENTS \RPCClearHeaderLength))
(end (LRSH pup:PUPLENGTH-\PUPOVLEN 1)))
(nBlks←(words+\DESBlockSize-1)/\DESBlockSize)
(check←nBlks*\DESBlockSize-words) (* checksum is number of rounding words)
(RPTQ check (PROGN (PUTPUPWORD pup end 0)
(add end 1)))
(PUTPUPWORD pup end (\LONUM check))
(PUTPUPWORD pup end+1 (\HINUM check))
(add pup:PUPLENGTH (LLSH check+2 1))
(SELECTQ conv:level
(CBCCheck (CryptData conv:convKey nBlks cryptBase cryptBase 'encrypt
'cbcCheck
conv:iv))
((ECB CBC)
(Signal 'NotImplementedYet
conv:level))
(SHOULDNT])
(\DecryptPup
[LAMBDA (pup conv) (* ht: "26-Sep-84 18:19")
(PROG ((nBlks (((LRSH pup:PUPLENGTH-\PUPOVLEN 1)
-\RPCClearHeaderLength)/\DESBlockSize))
(cryptBase (\ADDBASE pup:PUPCONTENTS \RPCClearHeaderLength))
(checkAddr ((LRSH pup:PUPLENGTH-\PUPOVLEN 1)
-\RPCCheckLength))
check)
(SELECTQ conv:level
(CBCCheck (CryptData conv:convKey nBlks cryptBase cryptBase 'decrypt
'cbcCheck
conv:iv))
((ECB CBC)
(Signal 'NotImplementedYet
conv:level))
(SHOULDNT))
(check←(\MAKENUMBER (GETPUPWORD pup checkAddr+1)
(GETPUPWORD pup checkAddr)))
(RETURN (AND (IGREATERP check -1)
(ILESSP check \DESBlockSize])
)
(* Utilities)
(DEFINEQ
(\RPCOpenClosest
[LAMBDA (PORTLIST type) (* ht: " 8-Apr-85 09:46")
(* FIND THE "closest" respondant on portList. EchoMe polling to determine responsiveness is to pollSoc, connection
will go to connSoc. We poll in order from nearest to farest by hop order, use broadcast on local net if appropriate,
and hope not to engage too many folks before the real thing comes along. The basic structure of this is owed to
Taft)
(PROG (PUP SOC CNTIME BETWEENPROBE NEXTPORT PORT VAL LOCALFLG (MYNET ((ETHERHOSTNUMBER):PUPNET#)))
(if PORTLIST←(for PORT in PORTLIST collect PORT unless (if PORT:1:PUPNET#=MYNET
then LOCALFLG←T))
then PORTLIST←(SORT.PUPHOSTS.BY.DISTANCE PORTLIST))
(if LOCALFLG
then (* if there were some local hosts on the list, remove
them and add a broadcast port)
(push PORTLIST (<(create PUPADDRESS
PUPNET# ← MYNET
PUPHOST# ← 0)
>))
elseif PORTLIST=NIL
then (RETURN))
(SOC←(\GETMISCSOCKET))
(CNTIME←(SETUPTIMER \CONNECTTIMEOUT))
(NEXTPORT←PORTLIST)
(DISCARDPUPS SOC) (* clear out anything left over from other activities)
(RETURN (do (if (OR BETWEENPROBE=NIL (TIMEREXPIRED? BETWEENPROBE))
then (PORT←(PROG1 NEXTPORT:1 NEXTPORT←(OR NEXTPORT::1 PORTLIST)))
(PUP←(ALLOCATE.PUP))
(SETUPPUP PUP PORT:1 \RPCDefaultSocket \PT.ECHOME NIL SOC
'FREE)
(PUTPUPSTRING PUP type)
(SENDPUP SOC PUP)
(BETWEENPROBE←(SETUPTIMER \BETWEENPROBEDELAY BETWEENPROBE)))
(BLOCK)
(if (AND (SETQ PUP (GETPUP SOC))
PUP:PUPTYPE=\PT.IAMECHO)
then (RETURN <PUP:PUPSOURCE ! PUP:PUPSOURCESOCKET>))
repeatuntil (TIMEREXPIRED? CNTIME])
(\SetupResponse
[LAMBDA (pup conv id dest) (* ht: " 4-SEP-83 18:23")
(if conv
then (pup:destPSB←dest)
(pup:PUPCONTENTS:conversationID←conv)
(pup:PUPCONTENTS:callAgent←id)
else (* better be a pup from our interlocutor)
(pup:destPSB←pup:sourcePSB)
(pup:DEST←pup:SOURCE))
pup:DESTSKT←\RPCSocketNumber])
(\ReceiveExtra
[LAMBDA (pup conv) (* ht: "28-Sep-84 01:27")
pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen)
pup←(\ExchangePackets pup \stReceiving (FUNCTION CantCatchHere)
conv)
(\SetupResponse pup)
(if pup:EOM
then (pup:PUPCONTENTS:MDSBase←\rcResult) (* note we overwrite the MDSBase hint here, but as we
don%'t use it it doesn%'t matter))
pup:dataOffset←\RPCPupWordOvLen
pup])
(\SendExtra
[LAMBDA (pup conv) (* ht: "27-Jul-85 14:45")
(if (\ExchangePackets pup \stSending (FUNCTION CantCatchHere)
conv)
then (HELP "shouldn't get an answer")
else (pup:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen])
(CheapHopsToNet
[LAMBDA (net) (* ht: " 2-SEP-83 15:13")
(* don't do any work -
fake it if not here)
(PROG (e)
(RETURN (if e←(FASSOC net \PUP.ROUTING.TABLE)
then e:2
else (* guess high)
5])
(\CheckRPC
[LAMBDA NIL (* ht: "22-JAN-83 14:40")
(if ~(AND \BinderDisp (PROCESSP (FIND.PROCESS \RPCTopProc)))
then (\RPCNotAliveErr])
(\RPCNotAliveErr
[LAMBDA NIL (* ht: "10-JUN-83 10:20")
(Signal (QUOTE RPCDead)
"Please do InitRPC() and try again"])
(\ServerError
[LAMBDA (arg handle) (* ht: "27-Sep-84 18:30")
(printout T "Lisp error in server: " # (ERRORMESS arg:eMess)
"saving arg and carrying on" T)
(if (ILESSP (LENGTH \RPCServerErrors)
\RPCMaxServerErrors)
then \RPCServerErrors← < !! \RPCServerErrors <(GDATE)
arg < ! handle>>>)
(RELSTK arg:ePos])
(\InitRPCVars
[LAMBDA NIL (* ht: " 3-Jan-85 13:23")
\MatchAnyVersion←(create VersionRange)
\NoDispDetails←(create DispDetails])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS FILLPUPSOURCE MACRO ((pup)
(PROGN (* zero causes SENDPUP to do it)
(replace PUPSOURCESOCKET of pup with 0)
(replace PUPSOURCE of pup with 0]
)
)
(* Authentication)
(DEFINEQ
(\ReplyToRFA
[LAMBDA (call request conv activity callCount) (* ht: "26-Sep-84 19:54")
(* = RPCSecurity.ReplyToRFA)
(PROG (nonceID)
(if [OR ~(IEQP request:PUPCONTENTS:callerConv call:PUPCONTENTS:conversationID)
~(for o from 0 to 3
always (* check the packet ID)
(IEQP (\GETBASE request:PUPCONTENTS o+\RPCRFAcallerIDOffset)
(\GETBASE call:PUPCONTENTS o+\RPCPktIDOffset]
then (RELEASE.PUP request)
(RETURN))
(request:dataOffset←(CONSTANT \RPCPupWordOvLen+\NonceIdOffset))
(nonceID←(\GetArgDblWord request)) (* turn the pup around)
(\SetupResponse request)
(FILLPUPSOURCE request)
(request:sourcePSB←0)
(request:PUPLENGTH←(CONSTANT \PUPOVLEN+\RPCPupByteOvLen))
(\AddPupDblWord request 0) (* the iv)
(\AddPupDblWord request 0)
(request:PUPCONTENTS:trueConv←call:PUPCONTENTS:conversationID)
(add request:PUPLENGTH 4)
(\AddPupWord request call:SOURCE)
(\AddPupWord request activity)
(\AddPupDblWord request callCount)
(\AddPupDblWord request nonceID+1)
(if (IEQP call:PUPCONTENTS:conversationID \RPCConvID)
then (* we started this, in the clear)
(\AddPupWord request 0)
(\AddPupWord request 0) (* auth. lenght -
needed to get pup length right)
(* level = none)
else (* encrypted -
oh boy)
(if call:PUPCONTENTS:conversationID:originatorP=1
then (Signal 'NotMeBoss))
(\AddPupWord request 4) (* cheat -
this is CBCCheck, the only thing we know)
(\BLT (\ADDBASE request:PUPCONTENTS \RPCPupWordOvLen)
conv:iv:ARRAYP.BASE 4)
(CryptData conv:convKey \RPCRespCKBlocks (\ADDBASE request:PUPCONTENTS
\RPCPupWordOvLen)
(\ADDBASE request:PUPCONTENTS \RPCPupWordOvLen)
'encrypt
'cbcCheck
\RPCNullSeed)
(\AddPupWord request (ARRAYSIZE conv:authenticator))
(for i from 0 to (ARRAYSIZE conv:authenticator)+-1 do (\AddPupWord request
(ELT
conv:authenticator i)))
(\PutBinderString request conv:caller))
(request:class←\clData)
(request:EOM←T)
(request:ack←NIL)
(add request:PUPCONTENTS:packetSeq 1)
(SENDPUP \RPCSocket request)
(RELEASE.PUP request)
(RETURN T])
(\GetConnectionState
[LAMBDA (pup) (* ht: "27-Sep-84 18:49")
(if \RPCDontBotherWithRFA
then T
else (PROG ((rfa (ALLOCATE.PUP))
(nonceId (CLOCK))
response level conv)
(SETUPPUP rfa pup:SOURCE \RPCSocketNumber 96 0 \RPCSocket)
(rfa:PUPCONTENTS:callerConv←pup:PUPCONTENTS:conversationID)
(for o from 0 to 3 do (\PUTBASE rfa:PUPCONTENTS o+\RPCRFAcallerIDOffset
(\GETBASE pup:PUPCONTENTS o+\RPCPktIDOffset)))
(rfa:PUPLENGTH←(CONSTANT \RPCPupByteOvLen+\PUPOVLEN+(LLSH \NonceIdOffset 1)))
(\AddPupDblWord rfa nonceId)
(\SetupResponse rfa \RPCConvID 0 pup:sourcePSB)
(rfa:PUPCONTENTS:packetSeq←0)
(response←(\ExchangePackets rfa \stAuthReq))
(if (ILESSP response:PUPLENGTH-\PUPOVLEN 26)
then (PUPDEBUGGING T "too small")
(RETURN))
(SELECTQ (level←(GETPUPWORD response (CONSTANT \RPCPupWordOvLen+12)))
(0 (* no encryption -
fine)
NIL)
((1 2 3)
(HELP "level not implemented yet" level))
[4 (* CBCCheck encryption -
we can do it)
(PROG ((kb (CorrectParity (COPYARRAY DESNullKey)))
(tempKey (ARRAY 8 '(BITS 8)
0 0))
iv)
(DecryptBlock kb (\ADDBASE response:PUPCONTENTS (CONSTANT
\RPCAuthenticatorOffset+\RPCAuthKyPos))
(\ADDBASE response:PUPCONTENTS (CONSTANT
\RPCAuthenticatorOffset+\RPCAuthKyPos)))
(\BLT tempKey:ARRAYP.BASE (\ADDBASE response:PUPCONTENTS
(CONSTANT
\RPCAuthenticatorOffset+\RPCAuthKyPos))
4)
(CryptData tempKey (GETPUPWORD response (CONSTANT
\RPCPupWordOvLen+13))
/\DESBlockSize-2 (\ADDBASE response:PUPCONTENTS
(CONSTANT
\RPCAuthenticatorOffset+\RPCAuthConvKeyPos))
(\ADDBASE response:PUPCONTENTS (CONSTANT
\RPCAuthenticatorOffset+\RPCAuthConvKeyPos))
'decrypt
'cbcCheck
\RPCNullSeed)
(DecryptBlock kb (\ADDBASE response:PUPCONTENTS (CONSTANT
\RPCAuthenticatorOffset+\RPCAuthConvKeyPos))
(\ADDBASE response:PUPCONTENTS (CONSTANT
\RPCAuthenticatorOffset+\RPCAuthConvKeyPos)))
(\BLT tempKey:ARRAYP.BASE (\ADDBASE response:PUPCONTENTS
(CONSTANT
\RPCAuthenticatorOffset+\RPCAuthConvKeyPos))
4)
(CryptData tempKey \RPCRespCKBlocks (\ADDBASE response:PUPCONTENTS
\RPCPupWordOvLen)
(\ADDBASE response:PUPCONTENTS \RPCPupWordOvLen)
'decrypt
'cbcCheck
\RPCNullSeed)
(conv←(create Conversation
cId ←(create ConversationID
originatorC ←(if
response:PUPCONTENTS:trueConv:originatorP=0
then
(GETPUPWORD
response
(CONSTANT
\RPCPupWordOvLen+6))
else (ETHERHOSTNUMBER))
count ←(LOGAND
response:PUPCONTENTS:trueConv
-32769))
level ← 'CBCCheck
iv ←(PROG1 iv←(ARRAY 8 '(BITS 8)
0 0)
(\BLT iv:ARRAYP.BASE (\ADDBASE
response:PUPCONTENTS
\RPCPupWordOvLen)
4))
caller ←(\GETBASESTRING response:PUPCONTENTS
(CONSTANT (LLSH
\RPCAuthenticatorOffset+\RPCAuthNamePos+\RPCStringHeaderLength 1))
(GETPUPWORD response
(CONSTANT
\RPCAuthenticatorOffset+\RPCAuthNamePos)))
convKey ←(COPYARRAY tempKey)))
(OR (\DecryptPup pup conv)
(PUPDEBUGGING T "didn't decrypt")
(RETURN]
(SHOULDNT))
(if ~[IEQP nonceId+1 (\MAKENUMBER (GETPUPWORD response (CONSTANT
\RPCPupWordOvLen+10+1))
(GETPUPWORD response (CONSTANT \RPCPupWordOvLen+10]
then (PUPDEBUGGING T "nonceID#")
(RETURN))
(if ~(AND (IEQP response:PUPCONTENTS:trueConv pup:PUPCONTENTS:conversationID)
pup:SOURCE=(GETPUPWORD response (CONSTANT \RPCPupWordOvLen+6))
pup:PUPCONTENTS:callAgent=(GETPUPWORD response (CONSTANT
\RPCPupWordOvLen+7)))
then (PUPDEBUGGING T "connection wrong")
(RETURN))
(if ~[IEQP pup:PUPCONTENTS:callCount (\MAKENUMBER (GETPUPWORD response (CONSTANT
\RPCPupWordOvLen+9))
(GETPUPWORD response (CONSTANT
\RPCPupWordOvLen+8]
then (PUPDEBUGGING T "callCount wrong")
(RETURN))
(RETURN (OR conv T])
)
(* Misc. constants)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \RPCLupineArgStart 11)
(RPAQQ \RPCPupWordOvLen 10)
(RPAQQ \RPCPupByteOvLen 20)
(RPAQQ \RPCMaxDataOffset 264)
(RPAQQ \RPCMaxPupLength 550)
(RPAQQ \RPCRetransTimeout 1000)
(RPAQQ \RPCPingTimeout 5000)
(RPAQQ \RPCMaxPingTimeout 60000)
(RPAQQ \RPCMaxTransCount 14)
(RPAQQ \RPCTransTimeoutIncr 100)
(RPAQQ \RPCDelayPerHop 500)
(RPAQQ \NonceIdOffset 6)
(RPAQQ \RPCPktIDOffset 2)
(RPAQQ \RPCRFAcallerIDOffset 12)
(RPAQQ \PT.ECHOME 1)
(RPAQQ \PT.IAMECHO 2)
(RPAQQ \PUPOVLEN 22)
(RPAQQ \RPCStringHeaderLength 2)
(RPAQQ \RPCCheckLength 2)
(RPAQQ \RPCClearHeaderLength 2)
(RPAQQ \RPCRespCKBlocks 3)
(CONSTANTS (\RPCLupineArgStart 11)
(\RPCPupWordOvLen 10)
(\RPCPupByteOvLen 20)
(\RPCMaxDataOffset 264)
(\RPCMaxPupLength 550)
(\RPCRetransTimeout 1000)
(\RPCPingTimeout 5000)
(\RPCMaxPingTimeout 60000)
(\RPCMaxTransCount 14)
(\RPCTransTimeoutIncr 100)
(\RPCDelayPerHop 500)
(\NonceIdOffset 6)
(\RPCPktIDOffset 2)
(\RPCRFAcallerIDOffset 12)
(\PT.ECHOME 1)
(\PT.IAMECHO 2)
(\PUPOVLEN 22)
(\RPCStringHeaderLength 2)
(\RPCCheckLength 2)
(\RPCClearHeaderLength 2)
(\RPCRespCKBlocks 3))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \stReceiving receiving)
(RPAQQ \stSending sending)
(RPAQQ \stCall call)
(RPAQQ \stEndCall endCall)
(RPAQQ \stAuthReq authReq)
(CONSTANTS (\stReceiving 'receiving)
(\stSending 'sending)
(\stCall 'call)
(\stEndCall 'endCall)
(\stAuthReq 'authReq))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \rcResult 0)
(RPAQQ \rcUnbound 1)
(RPAQQ \rcSignal 2)
(RPAQQ \rcUnwind 3)
(RPAQQ \rcProtocol 4)
(CONSTANTS (\rcResult 0)
(\rcUnbound 1)
(\rcSignal 2)
(\rcUnwind 3)
(\rcProtocol 4))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \clCall 0)
(RPAQQ \clData 1)
(RPAQQ \clAck 2)
(RPAQQ \clRFA 4)
(CONSTANTS (\clCall 0)
(\clData 1)
(\clAck 2)
(\clRFA 4))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \ecUnbound unbound)
(RPAQQ \ecTimeout timeout)
(CONSTANTS (\ecUnbound 'unbound)
(\ecTimeout 'timeout))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \RPCAuthKyPos 0)
(RPAQQ \RPCAuthConvKeyPos 8)
(RPAQQ \RPCAuthTimePos 16)
(RPAQQ \RPCAuthNamePos 18)
(RPAQQ \RPCAuthFixedLength 18)
(RPAQQ \RPCAuthenticatorOffset 24)
(CONSTANTS (\RPCAuthKyPos 0)
(\RPCAuthConvKeyPos 8)
(\RPCAuthTimePos 16)
(\RPCAuthNamePos 18)
(\RPCAuthFixedLength 18)
(\RPCAuthenticatorOffset 24))
)
)
(* Global parameters)
(RPAQ? \RPCNullSeed (ARRAY 8 '(BITS 8)
0 0))
(RPAQ? \HandleCnt 0)
(RPAQ? \HandleOverflow )
(RPAQ? \ConnectionTimeout 6)
(RPAQ? \CheckConnectionsInterval 60000)
(RPAQ? \RPCConnections )
(RPAQ? \RPCConversations )
(RPAQ? \RPCLastConversation )
(RPAQ? \RPCHandles )
(RPAQ? \RPCWanting )
(RPAQ? \RPCDefaultSocket 30)
(RPAQ? \BinderDisp )
(RPAQ? \RPCConvID )
(RPAQ? \RPCDontBotherWithRFA )
(RPAQ? \RPCDebugWaitForever )
(RPAQ? \RPCNumberOfServers 0)
(RPAQ? \RPCMaxServers 5)
(RPAQ? \RPCMaxIdlers 3)
(RPAQ? \RPCIdlers )
(RPAQ? \RPCDebugServers )
(RPAQ? \RPCServerErrors )
(RPAQ? \RPCMaxServerErrors 25)
(DECLARE: EVAL@COMPILE
[PUTDEF '\RPCScratchStream
'RESOURCES
'(NEW (OPENSTREAM '{NODIRCORE}
'BOTH
'NEW)
FREE
(SETFILEPTR (SETQ \\RPCScratchStream.GLOBALRESOURCE (PROGN . ARGS))
0))]
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \RPCNullSeed \HandleCnt \HandleOverflow \RPCConnections \RPCConversations
\RPCLastConversation \RPCHandles \RPCWanting \RPCDefaultSocket \BinderDisp \CallCnt
\RPCConvID \RPCDontBotherWithRFA \RPCDebugWaitForever \RPCNumberOfServers \RPCMaxServers
\RPCMaxIdlers \RPCIdlers \ConnectionTimeout \CheckConnectionsInterval \RPCDebugServers
\RPCServerErrors \RPCMaxServerErrors)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS ExportTable \RPCTopProc \RPCSocket \RPCSocketNumber ExportCount)
)
(* The block records here reflect Andrew's layout of the transport mechanism in
{INDIGO}<CEDAR>RPC>RPCPkt.mesa and should track any changes made there)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD Connection (((conv . convId)
remoteHost . callCnt)
processId activity . age))
(RECORD Conversation (((authenticator . cId)
convKey . iv)
level callee . caller))
(RECORD ConversationID (originatorC . count))
(RECORD DispDetails (dId dMds hint)
dMds ← 0 dId ← \NoDispatcher hint ← 0)
(RECORD ExportTableEntry (dispHint dispId mds dispatcher intName stubProt)
mds ← 0 stubProt ← \MatchAnyVersion)
(RECORD ImportInstance (host . dispDetails))
(RECORD InterfaceName (type instance version)
version ← \MatchAnyVersion)
(BLOCKRECORD PktConversationID ((ls BITS 16)
(originatorP BITS 1)
(ms BITS 15)))
(BLOCKRECORD RPCBinderArgs ((NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(request WORD)
(bindType WORD)
(bindInstance WORD)))
(RECORD RPCHandle (localId (remoteId . newPup)
event . process))
(BLOCKRECORD RPCPup ((NIL 32 WORD)
(destPSB WORD)
(sourcePSB WORD))
[ACCESSFNS RPCPup ([RPCP (EQ (LOGAND (fetch (PUP PUPTYPE) of DATUM)
224)
96)
(LAMBDA (D N)
(COND
(N (change (fetch (PUP PUPTYPE)
of D)
(LOGOR DATUM 96]
[EOM (NEQ (LOGAND (fetch (PUP PUPTYPE) of DATUM)
16)
16)
(LAMBDA (D N)
(change (fetch (PUP PUPTYPE) of D)
(COND
[N (LOGAND DATUM (CONSTANT (LOGXOR
255 16]
(T (LOGOR DATUM 16]
[ack (EQ (LOGAND (fetch (PUP PUPTYPE) of DATUM)
8)
8)
(LAMBDA (D N)
(change (fetch (PUP PUPTYPE) of D)
(COND
(N (LOGOR DATUM 8))
(T (LOGAND DATUM (CONSTANT (LOGXOR
255 8]
[class (LOGAND (fetch (PUP PUPTYPE) of DATUM)
7)
(LAMBDA (D N)
(change (fetch (PUP PUPTYPE) of D)
(LOGOR (LOGAND DATUM
(CONSTANT (LOGXOR
255 7)))
N]
(dataOffset (fetch (ETHERPACKET EPUSERFIELD) of DATUM)
(replace (ETHERPACKET EPUSERFIELD) of DATUM
with NEWVALUE])
(BLOCKRECORD RPCPupContents ((conversationID FIXP)
(callAgent WORD)
(callCountLo WORD)
(callCountHi WORD)
(packetSeq WORD)
(MDSBase WORD)
(dispatcherIdLo WORD)
(dispatcherIdHi WORD)
(dispatcherHint WORD))
[ACCESSFNS RPCPupContents ([dispatcherId [LAMBDA (D)
(\MAKENUMBER
(fetch dispatcherIdHi
of D)
(fetch dispatcherIdLo
of D]
(LAMBDA (D N)
(replace dispatcherIdHi
of D
with (\HINUM N))
(replace dispatcherIdLo
of D
with (\LONUM N]
(callCount [LAMBDA (D)
(\MAKENUMBER (fetch callCountHi
of D)
(fetch callCountLo
of D]
(LAMBDA (D N)
(replace callCountHi of D
with (\HINUM N))
(replace callCountLo of D
with (\LONUM N])
(BLOCKRECORD RPCRFAResponse ((NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(trueConv FIXP)))
(BLOCKRECORD RPCRFARequest ((NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(NIL FIXP)
(callerConv FIXP)))
(RECORD VersionRange (first . last)
first ← 1 last ← 0)
]
)
(RPAQQ \NoDispatcher 0)
(RPAQQ \MatchAnyVersion NIL)
(RPAQQ \NoDispDetails NIL)
(\InitRPCVars)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \NoDispatcher \MatchAnyVersion \NoDispDetails)
)
(* adding stuff to pups)
(DEFINEQ
(\PutBinderString
[LAMBDA (pup string) (* ht: "13-JAN-83 15:32")
(if string
then (\AddPupWord pup (NCHARS string))
(\AddPupWord pup (NCHARS string))
(\PUTPUPSTRING pup string)
(if (ODDP pup:PUPLENGTH)
then (add pup:PUPLENGTH 1))
(LRSH pup:PUPLENGTH-\RPCPupByteOvLen-\PUPOVLEN 1)
else 0])
(\AddRPCDispDetails
[LAMBDA (pup disp) (* ht: "27-Sep-84 22:52")
(\AddPupWord pup disp:dMds)
(\AddPupDblWord pup disp:dId)
(\AddPupWord pup disp:hint])
(\AddRPCVersion
[LAMBDA (pup version) (* ht: "10-SEP-82 22:26")
(\AddPupWord pup version:first)
(\AddPupWord pup version:last])
(\AddPupDblWord
[LAMBDA (pup dblWord conv) (* ht: "27-Sep-84 22:53")
(* ********** Note Inversion!!!!! ***********)
(\AddPupWord pup (\LONUM dblWord)
conv)
(\AddPupWord pup (\HINUM dblWord)
conv])
(\AddPupWord
[LAMBDA (pup word conv) (* ht: "27-Jul-85 15:11")
(if (IGEQ pup:PUPLENGTH \RPCMaxPupLength)
then (\SendExtra pup conv))
(PUTPUPWORD pup (LRSH pup:PUPLENGTH-\PUPOVLEN 1)
word)
(add pup:PUPLENGTH 2])
(\AddPupEnum
[LAMBDA (pup type val conv) (* ht: "27-Sep-84 22:59")
(\AddPupWord pup (for i from 0 as t in type do (if t=val
then (RETURN i))
finally (Signal 'BoundsCheck
<val ! type>))
conv])
(\AddPupSmallp
[LAMBDA (pup n conv) (* ht: "27-Sep-84 22:59")
(\AddPupWord pup (if (ILESSP n 0)
then n+65536
else n)
conv])
(\AddPupBoolean
[LAMBDA (pup bool conv) (* ht: "27-Sep-84 22:59")
(\AddPupWord pup (if bool
then 1
else 0)
conv])
(\MarshalStream
[LAMBDA (pup parm stream conv) (* ht: "27-Jul-85 15:11")
(* Note that the parm argument is ignored -
only needed for output)
(if (STRINGP stream)
then (\MarshalString pup stream conv)
else (if (IGREATERP pup:PUPLENGTH+4 \RPCMaxPupLength)
then (* in next pup)
(\SendExtra pup conv))
(if stream
then (if (NOT (TYPENAMEP stream 'STREAM))
then stream←(GETSTREAM stream))
(SETFILEPTR stream 0)
(\AddPupBoolean pup NIL conv)
(PROG ((length (GETEOFPTR stream)))
(\AddPupWord pup length conv)
(if length~=0
then (\MoveToPup pup length stream 0 conv))
(RETURN stream))
else (* ni lstream)
(\AddPupBoolean pup T)
(\AddPupWord pup 0])
(\MarshalArb
[LAMBDA (pup datum conv) (* ht: "30-Dec-85 16:18")
(DECLARE (GLOBALVARS \\RPCScratchStream.GLOBALRESOURCE))
(* * this is a manually expanded WITH-RESOURCE because of some weird INTERMEZZO bug -
ht)
([LAMBDA (\RPCScratchStream)
(LET ((stream \RPCScratchStream:1))
(PROG1 (PROGN (PRIN4 datum stream)
(\SETEOFPTR stream (GETFILEPTR stream))
(\MarshalStream pup NIL stream conv))
(SETFILEPTR stream 0)
(push \\RPCScratchStream.GLOBALRESOURCE \RPCScratchStream]
(if \\RPCScratchStream.GLOBALRESOURCE
then (pop \\RPCScratchStream.GLOBALRESOURCE)
else (CONS (OPENSTREAM '{NODIRCORE}
'BOTH
'NEW])
(\MarshalString
[LAMBDA (pup string conv) (* jtm: "12-Mar-86 09:36")
(* jtm: bug fix: string:STRINGP.FATSTRINGP dies if
string is NIL. \MarshalAtom passes NIL, so added a
test to make sure string was non-NIL.)
(if (AND string string:STRINGP.FATSTRINGP)
then (Signal 'NoFatStringsAllowedYet
string)
else (if (IGREATERP pup:PUPLENGTH+4 \RPCMaxPupLength)
then (* in next pup)
(\SendExtra pup conv))
(if string
then (\AddPupBoolean pup NIL conv)
(if (NOT (STRINGP string))
then string←(MKSTRING string))
(PROG ((length (NCHARS string)))
(\AddPupWord pup length conv)
(if length~=0
then (\MoveToPup pup length string:STRINGP.BASE
string:STRINGP.OFFST conv))
(RETURN string))
else (* ni lstring)
(\AddPupBoolean pup T)
(\AddPupWord pup 0])
(\MarshalAtom
[LAMBDA (pup atom conv) (* jtm: "10-Jan-86 14:23")
(\MarshalString pup (if atom
then (MKSTRING atom))
conv])
(\MoveToPup
[LAMBDA (pup #bytes source offset conv) (* ht: "27-Jul-85 15:11")
(if (IGREATERP #bytes+pup:PUPLENGTH \RPCMaxPupLength)
then (\MoveToMultPups pup #bytes source offset conv)
else (if (TYPENAMEP source 'STREAM)
then (\BINS source pup:PUPCONTENTS pup:PUPLENGTH-\PUPOVLEN #bytes)
else (\MOVEBYTES source offset pup:PUPCONTENTS pup:PUPLENGTH-\PUPOVLEN #bytes))
(add pup:PUPLENGTH (if (ODDP #bytes)
then #bytes+1
else #bytes])
(\MoveToMultPups
[LAMBDA (pup #bytes source offset conv) (* ht: "27-Jul-85 15:11")
(PROG ((initBytes (\RPCMaxPupLength-pup:PUPLENGTH))
pcb)
(pcb←(CONSTANT \RPCMaxPupLength-(\RPCPupByteOvLen+\PUPOVLEN)))
(if (TYPENAMEP source 'STREAM)
then (\BINS source pup:PUPCONTENTS pup:PUPLENGTH-\PUPOVLEN initBytes)
else (\MOVEBYTES source offset pup:PUPCONTENTS pup:PUPLENGTH-\PUPOVLEN initBytes))
(add pup:PUPLENGTH initBytes)
(bind mvd for bytesMoved from initBytes to #bytes by pcb
do (\SendExtra pup conv)
(mvd←(MIN #bytes-bytesMoved pcb))
(if (TYPENAMEP source 'STREAM)
then (\BINS source pup:PUPCONTENTS pup:PUPLENGTH-\PUPOVLEN mvd)
else (\MOVEBYTES source offset+bytesMoved pup:PUPCONTENTS pup:PUPLENGTH-\PUPOVLEN
mvd))
(add pup:PUPLENGTH mvd))
(if (ODDP #bytes)
then (add pup:PUPLENGTH 1])
)
(* Picking stuff out of pups)
(DEFINEQ
(\GetBinderString
[LAMBDA (contents offset nextOffset) (* ht: "10-JUN-83 09:05")
(* mesa strings are a word of length, an ignored word of
maxLength and the bytes)
(if offset~=nextOffset
then (\GETBASESTRING contents \RPCPupByteOvLen+(LLSH offset 1)+ 4 (\GETBASE contents
offset+\RPCPupWordOvLen])
(\GetArgDisp
[LAMBDA (pup) (* ht: " 7-JAN-83 16:39")
(create DispDetails
dMds ←(\GetArgWord pup)
dId ←(\GetArgDblWord pup)
hint ←(\GetArgWord pup])
(\GetArgVersion
[LAMBDA (pup) (* ht: " 7-JAN-83 16:30")
(create VersionRange
first ←(\GetArgWord pup)
last ←(\GetArgWord pup])
(\GetArgDblWord
[LAMBDA (pup conv) (* ht: "27-Sep-84 23:04")
(* ******** Note Inversion *********)
([LAMBDA (loWord)
(\MAKENUMBER (\GetArgWord pup conv)
loWord]
(\GetArgWord pup conv])
(\GetArgWord
[LAMBDA (pup conv) (* ht: " 1-Aug-85 08:56")
(if (IGEQ pup:dataOffset \RPCMaxDataOffset)
then (* need another pup)
(pup←l..cPup←(\ReceiveExtra pup conv)))
(GETPUPWORD pup (PROG1 pup:dataOffset (add pup:dataOffset 1])
(\GetArgEnum
[LAMBDA (pup type conv) (* ht: "27-Sep-84 23:03")
(CAR (NTH type (\GetArgWord pup conv)+ 1])
(\GetArgBool
(LAMBDA (pup conv) (* lmm "30-Apr-85 13:23") (NEQ (\GetArgWord pup conv) 0)))
(\GetArgSmallp
[LAMBDA (pup conv) (* ht: "27-Sep-84 23:02")
(PROG (n)
(RETURN (if (IGREATERP n←(\GetArgWord pup conv)
32767)
then n-65536
else n])
(\UnmarshalString
[LAMBDA (pup conv) (* jtm: "10-Jan-86 14:15")
[if (IGREATERP (PLUS (fetch dataOffset of pup)
2)
\RPCMaxDataOffset)
then (* in next pup)
(SETQ l..cPup (SETQ pup (\ReceiveExtra pup conv]
(if (\GetArgBool pup conv)
then (* ni lstring)
(\GetArgWord pup conv)
NIL
else (PROG ((length (\GetArgWord pup conv))
str)
(SETQ str (ALLOCSTRING length))
(if (NEQ length 0)
then (\MoveFromPup pup (LRSH (PLUS length 1)
1)
(fetch (STRINGP BASE) of str)
conv))
(RETURN str])
(\UnmarshalStream
[LAMBDA (pup stream conv) (* jtm: "10-Jan-86 14:23")
(if (IGREATERP pup:dataOffset+2 \RPCMaxDataOffset)
then (* in next pup)
(l..cPup←pup←(\ReceiveExtra pup conv)))
(if (\GetArgBool pup conv)
then (* empty string)
(\GetArgWord pup conv)
NIL
else (PROG (length (stream (stream:1)))
(length←(\GetArgWord pup conv))
(OR (STREAMP stream)
stream←(OPENSTREAM stream 'BOTH
'NEW))
(if length~=0
then (\MoveFromPup pup (LRSH length+1 1)
stream conv))
(SETFILEPTR stream 0)
(\SETEOFPTR stream length)
(RETURN stream])
(\UnmarshalArb
[LAMBDA (pup conv) (* ht: "30-Dec-85 16:13")
(DECLARE (GLOBALVARS \\RPCScratchStream.GLOBALRESOURCE))
(* * this is a manually expanded WITH-RESOURCE because of some weird INTERMEZZO bug -
ht)
([LAMBDA (\RPCScratchStream)
(PROG1 (READ (\UnmarshalStream pup \RPCScratchStream conv))
(SETFILEPTR \RPCScratchStream:1 0)
(push \\RPCScratchStream.GLOBALRESOURCE \RPCScratchStream]
(if \\RPCScratchStream.GLOBALRESOURCE
then (pop \\RPCScratchStream.GLOBALRESOURCE)
else (CONS (OPENSTREAM '{NODIRCORE}
'BOTH
'NEW])
(\UnmarshalAtom
[LAMBDA (pup conv) (* ht: "27-Sep-84 23:01")
(MKATOM (\UnmarshalString pup conv])
(\MoveFromPup
[LAMBDA (pup #words dest conv) (* ht: "27-Jul-85 15:11")
(if (IGREATERP #words+pup:dataOffset \RPCMaxDataOffset)
then (\MoveFromMultPups pup #words dest conv)
else (if (TYPENAMEP dest 'STREAM)
then (\BOUTS dest pup:PUPCONTENTS (LLSH pup:dataOffset 1)
(LLSH #words 1))
else (\BLT dest (\ADDBASE pup:PUPCONTENTS pup:dataOffset)
#words))
(add pup:dataOffset #words])
(\MoveFromMultPups
[LAMBDA (pup #words dest conv) (* ht: " 1-Aug-85 08:56")
(PROG ((initWords (\RPCMaxDataOffset-pup:dataOffset))
pcw)
(pcw←\RPCMaxDataOffset-\RPCPupWordOvLen)
(if (TYPENAMEP dest 'STREAM)
then (\BOUTS dest pup:PUPCONTENTS (LLSH pup:dataOffset 1)
(LLSH initWords 1))
else (\BLT dest (\ADDBASE pup:PUPCONTENTS pup:dataOffset)
initWords))
(bind mvd for wordsMoved from initWords to #words by pcw
do (pup←(\ReceiveExtra pup conv))
(if (TYPENAMEP dest 'STREAM)
then (\BOUTS dest pup:PUPCONTENTS (LLSH pup:dataOffset 1)
(LLSH mvd←(MIN #words-wordsMoved pcw)
1))
else (\BLT (\ADDBASE dest wordsMoved)
(\ADDBASE pup:PUPCONTENTS pup:dataOffset)
mvd←(MIN #words-wordsMoved pcw)))
finally (add pup:dataOffset mvd))
(l..cPup←pup])
(\IncrDataOffset
[LAMBDA (pup incr) (* ht: "25-Jul-85 18:07")
(add pup:dataOffset incr])
(\IncrPupLength
[LAMBDA (pup incr) (* ht: "26-Jul-85 14:51")
(add pup:PUPLENGTH incr])
(\CurrentPupBase
[LAMBDA (pup) (* ht: "25-Jul-85 18:06")
(\ADDBASE pup:PUPCONTENTS pup:dataOffset])
(\CurrentPupPosition
[LAMBDA (pup) (* ht: "26-Jul-85 14:54")
(\ADDBASE pup:PUPCONTENTS (LRSH (IDIFFERENCE pup:PUPLENGTH \PUPOVLEN)
1])
(\CheckPupOverflow
[LAMBDA (pup need) (* ht: " 1-Aug-85 09:23")
(if (IGREATERP (IPLUS pup:PUPLENGTH need)
\RPCMaxPupLength)
then (\SendExtra pup l..conv])
(\CheckPupExhausted
[LAMBDA (pup need) (* ht: " 1-Aug-85 09:22")
(if (IGREATERP (IPLUS pup:dataOffset need)
\RPCMaxDataOffset)
then l..cPup←(\ReceiveExtra pup l..conv)
else pup])
(\SkipBytesOut
[LAMBDA (pup nBytes) (* ht: " 1-Aug-85 09:22")
(until (ILEQ pup:PUPLENGTH+nBytes \RPCMaxPupLength)
do (nBytes←nBytes-(\RPCMaxPupLength-pup:PUPLENGTH))
(pup:PUPLENGTH←\RPCMaxPupLength)
(\SendExtra pup l..conv)
finally (add pup:PUPLENGTH nBytes])
(\SkipWordsIn
[LAMBDA (pup nWords) (* ht: " 1-Aug-85 09:23")
(until (ILEQ pup:dataOffset+nWords \RPCMaxDataOffset)
do (nWords←nWords-(\RPCMaxDataOffset-pup:dataOffset))
(pup:dataOffset←\RPCMaxDataOffset)
(pup←l..cPup←(\ReceiveExtra pup l..conv))
finally (add pup:dataOffset nWords))
pup])
)
(* to control how much PUPTRACEFLG shows)
(ADDTOVAR PUPPRINTMACROS (96 INTEGER 4 WORDS 42 ...)
(97 INTEGER 4 WORDS 42 ...)
(98 INTEGER 4 WORDS 16 ...)
(104 INTEGER 4 WORDS 42 ...)
(105 INTEGER 4 WORDS 42 ...)
(106 INTEGER 4 WORDS 16 ...)
(120 INTEGER 4 WORDS 42 ...)
(100 INTEGER 4 WORDS 42)
(108 INTEGER 4 WORDS 42)
(121 INTEGER 4 WORDS 42 ...))
(RPAQQ RPCPUPTYPES ((\RPC.ACK 98)
(\RPC.DATA! 105)
(\RPC.PING 106)
(\RPC.CALL 96)
(\RPC.CALL! 104)
(\RPC.DATA 97)
(\RPC.CALL-! 120)
(\RPC.RFA 100)
(\RPC.RFA! 108)
(\RPC.DATA-! 121)))
(RPAQ PUPTYPES [UNION RPCPUPTYPES (LISTP (EVALV 'PUPTYPES])
(RPAQ PUPONLYTYPES (UNION PUPONLYTYPES (MAPCAR RPCPUPTYPES (FUNCTION CADR))))
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS PUPDEBUGGING MACRO ((X . Y)
(COND (PUPTRACEFLG (printout PUPTRACEFILE X . Y]
)
)
(DECLARE: DONTCOPY EVAL@COMPILE
(RESETSAVE DWIMIFYCOMPFLG T)
)
(FILESLOAD GRAPEVINE SIGNAL CRYPT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
CRYPT SIGNAL NOBOX ETHERRECORDS (IMPORT)
LLCHAR LLARRAYELT)
)
(PUTPROPS RPC COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5672 8283 (InitRPC 5682 . 7831) (StopRPC 7833 . 8281)) (8313 11935 (ImportInterface
8323 . 9972) (RemoteBind 9974 . 11720) (UnimportInterface 11722 . 11933)) (11965 16559 (Binder 11975
. 14007) (NewExportTableEntry 14009 . 14659) (ExportInterface 14661 . 16389) (UnexportInterface 16391
. 16557)) (16586 19588 (\Authenticate 16596 . 18617) (StartConversation 18619 . 19586)) (19626 40437
(\RPCTopProc 19636 . 21902) (\RPCServerProc 21904 . 29720) (\RoutePup 29722 . 30631) (\ExchangePackets
30633 . 39534) (\DoSignal 39536 . 40435)) (40466 44073 (\StartCall 40476 . 41750) (\Call 41752 .
42739) (\AbortRemote 42741 . 43409) (CantCatchHere 43411 . 43536) (\StartSignal 43538 . 43742) (
\StartReturn 43744 . 44071)) (44107 45726 (\SetWanting 44117 . 44259) (\ClearWanting 44261 . 44416) (
\Wanting 44418 . 44553) (\NewHandleCnt 44555 . 44864) (\NewProcess 44866 . 45339) (\FindHandle 45341
. 45550) (\KillHandle 45552 . 45724)) (45760 47740 (\EncryptPup 45770 . 46915) (\DecryptPup 46917 .
47738)) (47763 52585 (\RPCOpenClosest 47773 . 49875) (\SetupResponse 49877 . 50319) (\ReceiveExtra
50321 . 50840) (\SendExtra 50842 . 51157) (CheapHopsToNet 51159 . 51567) (\CheckRPC 51569 . 51776) (
\RPCNotAliveErr 51778 . 51960) (\ServerError 51962 . 52381) (\InitRPCVars 52383 . 52583)) (52824 60953
(\ReplyToRFA 52834 . 55821) (\GetConnectionState 55823 . 60951)) (69464 76539 (\PutBinderString 69474
. 69879) (\AddRPCDispDetails 69881 . 70106) (\AddRPCVersion 70108 . 70298) (\AddPupDblWord 70300 .
70633) (\AddPupWord 70635 . 70933) (\AddPupEnum 70935 . 71239) (\AddPupSmallp 71241 . 71452) (
\AddPupBoolean 71454 . 71648) (\MarshalStream 71650 . 72729) (\MarshalArb 72731 . 73543) (
\MarshalString 73545 . 74729) (\MarshalAtom 74731 . 74935) (\MoveToPup 74937 . 75501) (\MoveToMultPups
75503 . 76537)) (76578 84739 (\GetBinderString 76588 . 77022) (\GetArgDisp 77024 . 77261) (
\GetArgVersion 77263 . 77470) (\GetArgDblWord 77472 . 77801) (\GetArgWord 77803 . 78177) (\GetArgEnum
78179 . 78345) (\GetArgBool 78347 . 78441) (\GetArgSmallp 78443 . 78700) (\UnmarshalString 78702 .
79554) (\UnmarshalStream 79556 . 80412) (\UnmarshalArb 80414 . 81104) (\UnmarshalAtom 81106 . 81265) (
\MoveFromPup 81267 . 81781) (\MoveFromMultPups 81783 . 82811) (\IncrDataOffset 82813 . 82959) (
\IncrPupLength 82961 . 83105) (\CurrentPupBase 83107 . 83269) (\CurrentPupPosition 83271 . 83484) (
\CheckPupOverflow 83486 . 83720) (\CheckPupExhausted 83722 . 83990) (\SkipBytesOut 83992 . 84347) (
\SkipWordsIn 84349 . 84737)))))
STOP