-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathACCESS
400 lines (359 loc) · 15.7 KB
/
ACCESS
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
(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