(FILECREATED " 3-Apr-86 21:33:56" {LOGOS:AFB:SIP}<DOUG>LISP>ACCESS.;3 15492
changes to: (VARS ACCESSCOMS)
(FNS ACCESS)
previous date: " 1-Apr-86 17:15:26" {LOGOS:AFB:SIP}<DOUG>LISP>ACCESS.;2)
(* Copyright (c) 1986 by Speech Input Project, Univ. of Edinburgh. All rights reserved.)
(PRETTYCOMPRINT ACCESSCOMS)
(RPAQQ ACCESSCOMS ((FNS ACCESS ACCESS.PARSE ACCESS.PARSE.DIRECTORY ACCESS.DIRECTORYNAME
ACCESS.MKDIR ACCESS.PARSE.OBJ ACCESS.PARSE.ACCESS ACCESS.DO.COMMAND
ACCESS.OPEN ACCESS.SHOW ACCESS.ADD ACCESS.REMOVE ACCESS.CHANGE
ACCESS.SLASHIFY.DIRNAME ACCESS.NUM.TO.STRING ACCESS.STRING.TO.NUM)))
(DEFINEQ
(ACCESS
[LAMBDA NIL (* drc: " 3-Apr-86 21:32")
(* * Top level function. Parses a command line, checks args and performs commands.)
(bind (USER/PWD ←(\INTERNAL/GETPASSWORD NIL NIL NIL NIL NIL 'NS))
COM DIR OBJ ACCESS VALUE
do [SETQ VALUE (NLSETQ (LET ((COMMAND (ACCESS.PARSE DIR OBJ ACCESS USER/PWD)))
(SELECTQ (SETQ COM (CAR COMMAND))
(ABORT (PRINTOUT T "[aborted]"))
(Q (TERPRI T))
(L (SETQ USER/PWD (CDR COMMAND)))
(P (TERPRI T)
(USEREXEC '←←))
(PROGN (for X in (CDR COMMAND)
as Y
in '(DIR OBJ ACCESS)
do (SET Y X))
(ACCESS.DO.COMMAND USER/PWD COM DIR
OBJ ACCESS]
[if (NLISTP VALUE)
then (LET ((ERROR (ERRORN))) (* printout error messages, but treat CONROL-E errors
as aborts)
(if (EQ (CAR ERROR)
47)
then (PRINTOUT T "[aborted]")
else (ERRORMESS ERROR]
until (EQ COM 'Q])
(ACCESS.PARSE
[LAMBDA (DIR.DEFAULT OBJ.DEFAULT ACCESS.DEFAULT USER/PWD)
(* drc: " 1-Apr-86 17:09")
(* * Prompts for and parses one command line. Simulates ASKUSER.)
(RESETFORM (CONTROL T)
(PROG (CHAR COMMAND DIR OBJ ACCESS USER PWD)
PARSE
(FRESHLINE T)
(printout T "FS: ")
(SETQ CHAR (CHCON1 (READC T T)))
(SELCHARQ CHAR
((L l)
(printout T "ogin")
(SETQQ COMMAND L)
(GO LOGIN))
((S s)
(printout T "how")
(SETQQ COMMAND S))
((A a)
(printout T "dd")
(SETQQ COMMAND A))
((R r)
(printout T "emove")
(SETQQ COMMAND R))
((C c)
(printout T "hange")
(SETQQ COMMAND C))
[(P p)
(printout T "ush (type OK to return)")
(RETURN (LIST 'P]
[(↑Y)
(printout T " (type OK to return)")
(RETURN (LIST 'P]
[(Q q)
(printout T "uit")
(RETURN (LIST 'Q]
((H h ?)
(printout T " one of:" T " L - Login," T " S - Show," T
" A - Add,"
T " R - Remove," T " C - Change," T
" P, ↑Y - Push,"
T "or Q - Quit.")
(GO PARSE))
((CR LF)
(GO PARSE))
(PROGN (PRIN1 (CHARACTER (CHARCODE ↑G)))
(GO PARSE)))
(SETQ DIR (ACCESS.PARSE.DIRECTORY DIR.DEFAULT USER/PWD))
[OR DIR (RETURN '(ABORT)]
[SELECTQ COMMAND
(S (* done w/ List parse)
(RETURN (LIST COMMAND DIR)))
(PROGN (SETQ OBJ (ACCESS.PARSE.OBJ OBJ.DEFAULT COMMAND))
[OR OBJ (RETURN '(ABORT)]
(SELECTQ COMMAND
(R
(* done w/ Remove parse)
(RETURN (LIST COMMAND DIR OBJ)))
(PROGN (SETQ ACCESS (ACCESS.PARSE.ACCESS
ACCESS.DEFAULT COMMAND))
[if ACCESS
then (RETURN (LIST COMMAND
DIR OBJ
ACCESS))
else (RETURN '(ABORT)]
(* done w/ add parse)
]
LOGIN
[SETQ USER (MKATOM (PROMPTFORWORD " (username)" (CAR USER/PWD)
NIL NIL NIL NIL (LIST
(CHARCODE CR)
(CHARCODE LF]
[OR USER (RETURN '(ABORT)]
(SETQ PWD (\ENCRYPT.PWD (PROMPTFORWORD " (password)" NIL NIL NIL "*")))
[OR PWD (RETURN '(ABORT)]
(RETURN (CONS COMMAND (CONS USER PWD])
(ACCESS.PARSE.DIRECTORY
[LAMBDA (DIR.DEFAULT USER/PWD DON'T.CHECK) (* drc: " 1-Apr-86 16:13")
(DECLARE (GLOBALVARS \CONNECTED.DIRECTORY))
(LET ((DIR (PROMPTFORWORD " (access to directory)" DIR.DEFAULT "the name of an NS directory"))
)
(if (NOT DIR)
then (* user just typed CR)
NIL
else (* default host to connected host)
[OR (FILENAMEFIELD DIR 'HOST)
(SETQ DIR (MKSTRING (PACKFILENAME 'HOST
(FILENAMEFIELD \CONNECTED.DIRECTORY
'HOST)
'DIRECTORY
DIR]
(if DON'T.CHECK
then DIR
elseif (ACCESS.DIRECTORYNAME DIR USER/PWD)
else (printout T " not an NS directory.")
NIL])
(ACCESS.DIRECTORYNAME
[LAMBDA (HOST/DIR USER/PWD) (* drc: " 1-Apr-86 16:35")
(if (AND (STRPOS ":" HOST/DIR)
(DIRECTORYNAMEP HOST/DIR))
then HOST/DIR
elseif [LET ((POS (STRPOS ">" HOST/DIR))) (* there are two >'s in HOST/DIR -- could be a
non-existant subdirectoryt)
(AND POS (STRPOS ">" HOST/DIR (ADD1 POS]
then (SELECTQ (ASKUSER DWIMWAIT 'Y
(CONCAT " Create subdirectory " HOST/DIR " ? "))
(Y (ACCESS.MKDIR HOST/DIR USER/PWD))
NIL])
(ACCESS.MKDIR
[LAMBDA (HOST/DIR USER/PWD) (* drc: " 1-Apr-86 16:54")
(RESETLST (LET* ((HOST (FILENAMEFIELD HOST/DIR 'HOST))
[DIR (ACCESS.SLASHIFY.DIRNAME (FILENAMEFIELD HOST/DIR 'DIRECTORY]
[PARENT (CONCATLIST (DREVERSE (CDR (FMEMB '/
(DREVERSE (UNPACK DIR]
(CONNECTION (ACCESS.OPEN HOST PARENT USER/PWD))
(STREAM (CAR CONNECTION))
(SESSION (CADR CONNECTION))
(HANDLE (CADDR CONNECTION)))
(COURIER.CALL STREAM 'FILING
'CREATE
HANDLE
(BQUOTE ((NAME , DIR)
(IS.DIRECTORY T)
(FILE.TYPE 1)))
NIL SESSION 'RETURNERRORS)
HOST/DIR])
(ACCESS.PARSE.OBJ
[LAMBDA (OBJ.DEFAULT COMMAND) (* drc: "28-Mar-86 13:24")
(LET [(OBJ (PROMPTFORWORD (CONCAT " (" (SELECTQ COMMAND
(C "for ")
"")
"user or group)")
OBJ.DEFAULT "an NS user or group name" NIL NIL NIL
(LIST (CHARCODE CR)
(CHARCODE LF]
(if (NOT OBJ)
then (* user typed CR)
NIL
else (if (CH.LOOKUP.OBJECT OBJ)
else (printout T " not an NS object.")
NIL])
(ACCESS.PARSE.ACCESS
[LAMBDA (ACCESS.DEFAULT COMMAND) (* drc: "28-Mar-86 13:25")
(LET ((ACCESS (PROMPTFORWORD (SELECTQ COMMAND
(C " (to be)")
(A " (with access)")
(SHOULDNT "UNKNOWN COMMAND"))
(AND ACCESS.DEFAULT (ACCESS.NUM.TO.STRING ACCESS.DEFAULT))
"A sequence of letters (R=Read, W=Write, A=Add, D=Delete, C=Change access list)"))
(ACCESS.BYTE NIL))
(if (NOT ACCESS)
then (* user just typed CR)
NIL
else (SETQ ACCESS.BYTE (ACCESS.STRING.TO.NUM ACCESS))
(if (AND ACCESS.BYTE (IGREATERP ACCESS.BYTE 0)
(ILESSP ACCESS.BYTE 32))
then ACCESS.BYTE
else (printout T " bad access specification.")
NIL])
(ACCESS.DO.COMMAND
[LAMBDA (USER/PWD COMMAND HOST/DIR NSNAME ACCESS) (* drc: " 1-Apr-86 16:37")
(* * Performs COMMAND (one of S, A, R, or C) * HOST/DIR should be an NS host & dir, NSNAME should be a valid NS
name (not used for S command), ACCESS should be an integer between 1 and 31 (not used for S or R commands).)
(RESETLST (PROG ((HOST (FILENAMEFIELD HOST/DIR 'HOST))
(DIR (FILENAMEFIELD HOST/DIR 'DIRECTORY))
CONNECTION STREAM SESSION HANDLE OLD.LIST)
(SETQ CONNECTION (ACCESS.OPEN HOST DIR USER/PWD))
(SETQ STREAM (CAR CONNECTION))
(SETQ SESSION (CADR CONNECTION))
(SETQ HANDLE (CADDR CONNECTION))
(SETQ OLD.LIST (CAADAR (COURIER.CALL STREAM 'FILING
'GET.ATTRIBUTES
HANDLE
(LIST 19)
SESSION)))
(* list of triples ala (NSNAME GroupOrIndividual
Access#))
(SELECTQ COMMAND
(S (ACCESS.SHOW HOST/DIR OLD.LIST))
(R (ACCESS.REMOVE NSNAME HOST/DIR OLD.LIST STREAM HANDLE SESSION)
)
(A (ACCESS.ADD NSNAME HOST/DIR ACCESS OLD.LIST STREAM HANDLE
SESSION))
(C (ACCESS.CHANGE NSNAME HOST/DIR ACCESS OLD.LIST STREAM HANDLE
SESSION))
(SHOULDNT])
(ACCESS.OPEN
[LAMBDA (HOST DIR USER/PWD) (* drc: " 1-Apr-86 16:26")
(* returns a list of a courier stream and a courier session on HOST for USER/PWD. If DIR is NON-nil, will also
return a handle for it. Note that this expects to be called from within a RESETLST.)
(LET ((CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS USER/PWD))
(STREAM (COURIER.OPEN HOST NIL NIL (CONCAT HOST " Access")))
SESSION HANDLE)
(RESETSAVE NIL (LIST 'CLOSEF?
STREAM))
(SETQ SESSION (COURIER.CALL STREAM 'FILING
'LOGON
(PARSE.NSNAME HOST)
(CAR CREDENTIALS)
(CDR CREDENTIALS)))
(if DIR
then (SETQ HANDLE (COURIER.CALL STREAM 'FILING
'OPEN
(LIST (LIST 'PATHNAME
(ACCESS.SLASHIFY.DIRNAME DIR)))
\NSFILING.NULL.HANDLE NIL SESSION))
(RESETSAVE NIL (LIST 'COURIER.CALL
STREAM
'FILING
'CLOSE
HANDLE SESSION T)))
(LIST STREAM SESSION HANDLE])
(ACCESS.SHOW
[LAMBDA (HOST/DIR L) (* edited: "11-Mar-86 11:01")
(printout T T "Access list for " HOST/DIR ":")
(for X in L do (printout T T " " (CAR X)
.TAB 20 " (" (L-CASE (CADR X))
" with "
(ACCESS.NUM.TO.STRING (CADDR X))
" access)"])
(ACCESS.ADD
[LAMBDA (NSNAME HOST/DIR ACCESS OLD.LIST STREAM HANDLE SESSION)
(* drc: "15-Mar-86 13:13")
(LET ((TRIPLE (if (CH.RETRIEVE.ITEM NSNAME 'USER)
then (LIST NSNAME 'INDIVIDUAL
ACCESS)
elseif (CH.RETRIEVE.ITEM NSNAME 'USERGROUP)
then (LIST NSNAME 'GROUP
ACCESS)
else (ERROR NSNAME "NOT AN NS OBJECT")))
VALUE)
(SETQ VALUE (COURIER.CALL STREAM 'FILING
'CHANGE.ATTRIBUTES
HANDLE
(LIST (LIST 'ACCESS.LIST
(LIST (CONS TRIPLE OLD.LIST)
NIL)))
SESSION
'RETURNERRORS))
(if (EQ (CAR VALUE)
'ERROR)
then (printout T T VALUE " Not added.")
else (printout T T "OK, " NSNAME " added to " HOST/DIR " with " (ACCESS.NUM.TO.STRING
ACCESS)
" access."])
(ACCESS.REMOVE
[LAMBDA (NSNAME HOST/DIR OLD.LIST STREAM HANDLE SESSION) (* drc: "15-Mar-86 13:14")
(LET ([ENTRY (bind (NAME.STRING ←(NSNAME.TO.STRING NSNAME)) for X in OLD.LIST
thereis (STREQUAL NAME.STRING (NSNAME.TO.STRING (CAR X]
VALUE)
(if ENTRY
then (SETQ VALUE (COURIER.CALL STREAM 'FILING
'CHANGE.ATTRIBUTES
HANDLE
(LIST (LIST 'ACCESS.LIST
(LIST (REMOVE ENTRY OLD.LIST)
NIL)))
SESSION
'RETURNERRORS))
(if (EQ (CAR VALUE)
'ERROR)
then (printout T T VALUE " Not removed.")
else (printout T T "OK, " NSNAME " removed from access list of " HOST/DIR ".")
)
else (printout T T NSNAME " not on access list for " HOST/DIR "."])
(ACCESS.CHANGE
[LAMBDA (NSNAME HOST/DIR ACCESS OLD.LIST STREAM HANDLE SESSION)
(* drc: "13-Mar-86 10:49")
(LET ([OLD.ENTRY (bind (NAME.STRING ←(NSNAME.TO.STRING NSNAME)) for X in OLD.LIST
thereis (STREQUAL NAME.STRING (NSNAME.TO.STRING (CAR X]
NEW.ENTRY VALUE)
(if OLD.ENTRY
then (SETQ NEW.ENTRY (LIST NSNAME (CADR OLD.ENTRY)
ACCESS))
(SETQ VALUE (COURIER.CALL STREAM 'FILING
'CHANGE.ATTRIBUTES
HANDLE
(LIST (LIST 'ACCESS.LIST
(LIST (SUBST NEW.ENTRY
OLD.ENTRY OLD.LIST)
NIL)))
SESSION
'RETURNERRORS))
(if (EQ (CAR VALUE)
'ERROR)
then (printout T T VALUE " Access not changed.")
else (printout T T "OK, " NSNAME "'s access to " HOST/DIR " changed to "
(ACCESS.NUM.TO.STRING ACCESS)
"."))
else (printout T T NSNAME " not on access list for " HOST/DIR "."])
(ACCESS.SLASHIFY.DIRNAME
[LAMBDA (DIR) (* drc: " 1-Apr-86 15:33")
(CONCATLIST (SUBST '/
'>
(UNPACK DIR])
(ACCESS.NUM.TO.STRING
[LAMBDA (NUM) (* edited: "11-Mar-86 11:24")
(* * Converts a numeric access code to a string representation)
(CONCATLIST (for MASK in '(16 8 4 2 1) as PROTECTION
in '(R W C A D) when (BITTEST NUM MASK) collect PROTECTION])
(ACCESS.STRING.TO.NUM
[LAMBDA (STRING) (* edited: "11-Mar-86 11:16")
(* * Converts from a string to a numeric representation of an access code. Does not do much error checking.
Error is signalled by a returning 0)
(APPLY (FUNCTION IPLUS)
(for CHAR in (UNPACK (U-CASE STRING)) collect (SELECTQ CHAR
(D 1)
(A 2)
(C 4)
(W 8)
(R 16)
(RETURN NIL])
)
(PUTPROPS ACCESS COPYRIGHT ("Speech Input Project, Univ. of Edinburgh" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (651 15392 (ACCESS 661 . 1868) (ACCESS.PARSE 1870 . 4784) (ACCESS.PARSE.DIRECTORY 4786
. 5653) (ACCESS.DIRECTORYNAME 5655 . 6259) (ACCESS.MKDIR 6261 . 7029) (ACCESS.PARSE.OBJ 7031 . 7612)
(ACCESS.PARSE.ACCESS 7614 . 8471) (ACCESS.DO.COMMAND 8473 . 9913) (ACCESS.OPEN 9915 . 11030) (
ACCESS.SHOW 11032 . 11386) (ACCESS.ADD 11388 . 12375) (ACCESS.REMOVE 12377 . 13222) (ACCESS.CHANGE
13224 . 14317) (ACCESS.SLASHIFY.DIRNAME 14319 . 14508) (ACCESS.NUM.TO.STRING 14510 . 14864) (
ACCESS.STRING.TO.NUM 14866 . 15390)))))
STOP