(FILECREATED "24-Feb-86 22:20:56" {ERIS}<LISPCORE>LIBRARY>CHATSERVER.;21 15778
changes to: (VARS CHATSERVERCOMS)
(FNS SIMPLECHATSERVER)
previous date: "20-Feb-86 17:28:51" {ERIS}<LISPCORE>LIBRARY>CHATSERVER.;20)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CHATSERVERCOMS)
(RPAQQ CHATSERVERCOMS ((FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN REMOTE.LOGIN
REQUIRED.LOGIN SWEEP.OFD \REMOTE.EXEC.OUTCHARFN)
(LISPXMACROS Logon)
(P (for I from 1 to 8 do (ECHOCHAR I (QUOTE IGNORE)))
(ECHOCHAR (CHARCODE CR)
(QUOTE SIMULATE))
(ECHOCHAR 0 (QUOTE SIMULATE)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA REMOTE.LOGIN)
(NLAML)
(LAMA)))
(INITVARS (CHATSERVER.PROFILE))
(ADDVARS (\SWEPT.OFDS))
(COMS (FNS SIMPLECHATSERVER)
(INITVARS (CHATSERVERWINDOW)
(CHATSERVERWINDOWREGION (QUOTE (11 228 392 190)))))))
(DEFINEQ
(CHATSERVER
[LAMBDA NIL (* lmm
"28-Jan-86 15:16")
(PROGN (PRINTOUT T "Remote " HERALDSTRING T T)
(if (AND (LISTGET CHATSERVER.PROFILE (QUOTE IDLE.ONLY))
(NOT \IDLING))
then (PRINTOUT T " Machine not in idle mode, login not allowed " T)
(DISMISS 10000)
else (COND
((OR (REQUIRED.LOGIN (APPEND CHATSERVER.PROFILE IDLE.PROFILE))
(REQUIRED.LOGIN (APPEND CHATSERVER.PROFILE IDLE.PROFILE))
(REQUIRED.LOGIN (APPEND CHATSERVER.PROFILE IDLE.PROFILE)))
(* try three times)
(USEREXEC (QUOTE "<remote>")))
(T (PRINTOUT T T "Sorry... bye" T])
(CHATSERVERWHENCLOSEDFN
[LAMBDA (STREAM) (* lmm
"22-Jan-86 18:25")
(LET [(PROC (STREAMPROP STREAM (QUOTE SERVER.PROCESS]
(AND PROC (FIND.PROCESS PROC)
(DEL.PROCESS PROC])
(CHATSERVEROPENFN
[LAMBDA (INSTREAM OUTSTREAM) (* lmm
"22-Jan-86 18:17")
(STREAMPROP INSTREAM (QUOTE SERVER.PROCESS)
(THIS.PROCESS))
[COND
((fetch (FDEV BUFFERED) of (fetch (STREAM DEVICE) of OUTSTREAM))
(pushnew \SWEPT.OFDS OUTSTREAM)
(OR (FIND.PROCESS (QUOTE SWEEP.OFD))
(ADD.PROCESS (QUOTE (SWEEP.OFD]
(PROGN (RESETSAVE (TERMINAL-INPUT (\CREATELINEBUFFER INSTREAM)))
(RESETSAVE (TERMINAL-OUTPUT OUTSTREAM))
(replace (STREAM OUTCHARFN) of OUTSTREAM with (FUNCTION \REMOTE.EXEC.OUTCHARFN))
(replace (STREAM EOLCONVENTION) of OUTSTREAM with CRLF.EOLC))
(CHATSERVER])
(REMOTE.LOGIN
[NLAMBDA X (* ejs: "26-Oct-85 02:36")
(printout PROMPTWINDOW T (GDATE)
": Remote login by "
(CAR X])
(REQUIRED.LOGIN
[LAMBDA (PROFILE) (* lmm
"20-Feb-86 15:30")
(PROG ((GROUP (LISTGET PROFILE (QUOTE ALLOWED.LOGINS)))
(AUTHTYPE (LISTGET PROFILE (QUOTE AUTHENTICATE)))
(NAME (USERNAME NIL NIL T))
PWD)
(COND
((NLISTP GROUP) (* no login check at
all)
(COND
((LISTGET PROFILE (QUOTE FORGET))
(SETPASSWORD NIL NAME "")))
(RETURN T)))
(COND
((EQ 0 (NCHARS NAME)) (* Not logged in, so
don't complain about
anything)
(RETURN T)))
[SETQ PWD
(COND
((AND (EQUAL GROUP (QUOTE (T)))
NAME) (* Only previous user
allowed to login)
(PROMPTFORWORD (CONCAT NAME " password:")
NIL NIL NIL (QUOTE *)))
(T (PROG1 [CDR (SETQ NAME (PROG1 [PROG [(NAME (PROMPTFORWORD
"Login (<return> to terminate): "
NAME NIL T NIL T
(CHARCODE (CR LF]
(RETURN (CONS (MKATOM NAME)
(PROMPTFORWORD " (password) " NIL
NIL T (QUOTE *]
(TERPRI T]
(SETQ NAME (MKSTRING (CAR NAME] (* decide whether
NAME and PWD are in
GROUP)
(RETURN (COND
((NULL PWD)
NIL)
([AND (OR (MEMB T GROUP)
(MEMB (QUOTE *)
GROUP))
(\IDLE.IS.PREVIOUS NAME PWD (EQUAL GROUP (QUOTE (T]
(* Previous user is
allowed to login.
Also, if only allowed
login is old user, but
old password is
unknown, allow it)
T)
((\IDLE.ISMEMBER GROUP NAME PWD)
(COND
((COND
[AUTHTYPE (\IDLE.AUTHENTICATE NAME PWD AUTHTYPE (NOT (MEMB T GROUP]
(T T))
(SETPASSWORD NIL NAME PWD)
(SETQ \IDLE.PASSWORD.SET T)
T))
(TERPRI T))
(T (PRINTOUT T "login incorrect" T)
NIL])
(SWEEP.OFD
[LAMBDA NIL (* lmm " 9-Jan-86 17:00")
(while \SWEPT.OFDS do (for X in \SWEPT.OFDS
do (if (NOT (OPENP X (QUOTE OUTPUT)))
then (SETQ \SWEPT.OFDS (REMOVE X \SWEPT.OFDS))
else (FORCEOUTPUT X))
(BLOCK])
(\REMOTE.EXEC.OUTCHARFN
[LAMBDA (STREAM CHARCODE) (* lmm
"23-Jan-86 19:47")
(* OUTCHARFN for
standard files)
(PROG NIL
(SELECTC (ffetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE))
(REAL.CCE (* All fat characters
are defined as REAL
according to \SYNCODE,
so we don't have worry
about any of the
special cases)
[COND
((EQ (\CHARSET CHARCODE)
(ffetch CHARSET of STREAM))
(BOUT STREAM (\CHAR8CODE CHARCODE)))
(T (BOUT STREAM NSCHARSETSHIFT)
(BOUT STREAM (freplace (STREAM CHARSET) of STREAM with (\CHARSET
CHARCODE)
))
(BOUT STREAM (\CHAR8CODE CHARCODE]
(add (ffetch CHARPOSITION of STREAM)
1))
(INDICATE.CCE (* Make sure that all
the chars in the
indicate-string fit on
the line or wrap-around
together.)
(for CH instring (\INDICATESTRING CHARCODE)
do (BOUT STREAM CH)
(add (ffetch CHARPOSITION of STREAM)
1)))
(SIMULATE.CCE [if (EQ CHARCODE ERASECHARCODE)
then (BOUT STREAM (CHARCODE ↑H))
(BOUT STREAM (CHARCODE SPACE))
(BOUT STREAM (CHARCODE ↑H))
(add (fetch CHARPOSITION of STREAM)
-1)
else (SELCHARQ CHARCODE
((EOL CR LF)
(BLOCK)
(\STOPSCROLL?)
(COND
((NEQ (\CHARSET CHARCODE)
(ffetch CHARSET of STREAM))
(BOUT STREAM NSCHARSETSHIFT)
(BOUT STREAM 0)))
(BOUT STREAM (SELECTC (ffetch EOLCONVENTION of STREAM)
(CR.EOLC (CHARCODE CR))
(LF.EOLC (CHARCODE LF))
(CRLF.EOLC (BOUT STREAM (CHARCODE
CR))
(* Don't put out high-order byte preceding LF.
The CRLF is EOL only if the bytes are immediately adjacent in the stream,
with no additional encoding bytes)
(CHARCODE LF))
(SHOULDNT)))
(freplace CHARPOSITION of STREAM with 0)
(freplace CHARPOSITION of STREAM with 0))
(ESCAPE (BOUT STREAM (CHARCODE $))
(add (ffetch CHARPOSITION of STREAM)
1))
(TAB (SPACES (DIFFERENCE 8 (MOD (POSITION)
8))
STREAM))
(PROGN (BOUT STREAM CHARCODE)
(add (ffetch CHARPOSITION of STREAM)
1])
(IGNORE.CCE)
(SHOULDNT)))
CHARCODE])
)
(ADDTOVAR LISPXMACROS (Logon (REQUIRED.LOGIN (QUOTE NS::))))
(for I from 1 to 8 do (ECHOCHAR I (QUOTE IGNORE)))
(ECHOCHAR (CHARCODE CR)
(QUOTE SIMULATE))
(ECHOCHAR 0 (QUOTE SIMULATE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA REMOTE.LOGIN)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(RPAQ? CHATSERVER.PROFILE )
(ADDTOVAR \SWEPT.OFDS )
(DEFINEQ
(SIMPLECHATSERVER
(LAMBDA (INSTREAM OUTSTREAM) (* lmm
"24-Feb-86 22:06")
(PROG ((WINDOW (OR CHATSERVERWINDOW (SETQ CHATSERVERWINDOW (CREATEW CHATSERVERWINDOWREGION
"Chat Listener"))))
(KEYSTREAM \KEYBOARD.STREAM)
MYSTREAM)
(printout OUTSTREAM "Xerox Lisp Chat echo service" T)
(CONTROL T)
(CLEARW WINDOW)
(WINDOWPROP WINDOW (QUOTE CLOSEFN)
(FUNCTION (LAMBDA (W)
(SETQ SIMPLECHATSERVERDONE T)
(AND (OPENWP W)
(WINDOWPROP W (QUOTE TITLE)
"Connection closed")))))
(TTYDISPLAYSTREAM (SETQ MYSTREAM (GETSTREAM WINDOW (QUOTE OUTPUT))))
(WINDOWPROP WINDOW (QUOTE PROCESS)
(THIS.PROCESS))
(bind CH do (WHILE (READP INSTREAM) do (\OUTCHAR OUTSTREAM (SETQ CH
(BIN INSTREAM))
)
(\OUTCHAR MYSTREAM CH))
(BLOCK)
(WHILE (READP KEYSTREAM) DO (\OUTCHAR OUTSTREAM (SETQ CH
(BIN KEYSTREAM)
))
(\OUTCHAR MYSTREAM CH))
(if (EQ (TTY.PROCESS)
(THIS.PROCESS))
then (\TTYBACKGROUND)
else (BLOCK)))
(printout MYSTREAM T T "Connection closed" T)
(WINDOWPROP WINDOW (QUOTE TITLE)
"Connection closed")
(WINDOWPROP WINDOW (QUOTE CLOSEFN)
NIL))))
)
(RPAQ? CHATSERVERWINDOW )
(RPAQ? CHATSERVERWINDOWREGION (QUOTE (11 228 392 190)))
(PUTPROPS CHATSERVER COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1417 12950 (CHATSERVER 1427 . 2369) (CHATSERVERWHENCLOSEDFN 2371 . 2702) (
CHATSERVEROPENFN 2704 . 3487) (REMOTE.LOGIN 3489 . 3687) (REQUIRED.LOGIN 3689 . 7486) (SWEEP.OFD 7488
. 7844) (\REMOTE.EXEC.OUTCHARFN 7846 . 12948)) (13353 15595 (SIMPLECHATSERVER 13363 . 15593)))))
STOP