0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 06-2013, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 3b 3b 0a 0a 28 75 73 65 nses/>..;;..(use
0300: 20 64 65 66 73 74 72 75 63 74 29 0a 28 75 73 65 defstruct).(use
0310: 20 73 63 73 68 2d 70 72 6f 63 65 73 73 29 0a 0a scsh-process)..
0320: 28 75 73 65 20 73 72 66 69 2d 31 38 29 0a 28 75 (use srfi-18).(u
0330: 73 65 20 73 72 66 69 2d 31 39 29 0a 28 75 73 65 se srfi-19).(use
0340: 20 72 65 66 64 62 29 0a 0a 28 75 73 65 20 73 71 refdb)..(use sq
0350: 6c 2d 64 65 2d 6c 69 74 65 20 73 72 66 69 2d 31 l-de-lite srfi-1
0360: 20 70 6f 73 69 78 20 72 65 67 65 78 20 72 65 67 posix regex reg
0370: 65 78 2d 63 61 73 65 20 73 72 66 69 2d 36 39 29 ex-case srfi-69)
0380: 0a 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 .;(declare (uses
0390: 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 28 64 65 63 6c common)).;(decl
03a0: 61 72 65 20 28 75 73 65 73 20 63 6f 6e 66 69 67 are (uses config
03b0: 66 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 f)).(declare (us
03c0: 65 73 20 6d 61 72 67 73 29 29 0a 0a 28 69 6e 63 es margs))..(inc
03d0: 6c 75 64 65 20 22 6d 65 67 61 74 65 73 74 2d 76 lude "megatest-v
03e0: 65 72 73 69 6f 6e 2e 73 63 6d 22 29 0a 28 69 6e ersion.scm").(in
03f0: 63 6c 75 64 65 20 22 6d 65 67 61 74 65 73 74 2d clude "megatest-
0400: 66 6f 73 73 69 6c 2d 68 61 73 68 2e 73 63 6d 22 fossil-hash.scm"
0410: 29 0a 3b 3b 3b 20 70 6c 65 61 73 65 20 63 72 65 ).;;; please cre
0420: 61 74 65 20 74 68 69 73 20 66 69 6c 65 20 62 65 ate this file be
0430: 66 6f 72 65 20 75 73 69 6e 67 20 73 61 75 74 68 fore using sauth
0440: 65 72 69 73 65 2e 20 46 6f 72 20 73 61 6d 70 6c erise. For sampl
0450: 65 20 66 69 6c 65 20 69 73 20 61 76 61 6c 69 61 e file is avalia
0460: 62 6c 65 20 73 61 6d 70 6c 65 2d 73 61 75 74 68 ble sample-sauth
0470: 2d 70 61 74 68 73 2e 73 63 6d 2e 20 0a 28 69 6e -paths.scm. .(in
0480: 63 6c 75 64 65 20 22 73 61 75 74 68 2d 70 61 74 clude "sauth-pat
0490: 68 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 hs.scm").(includ
04a0: 65 20 22 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 2e e "sauth-common.
04b0: 73 63 6d 22 29 0a 0a 3b 3b 0a 3b 3b 20 47 4c 4f scm")..;;.;; GLO
04c0: 42 41 4c 53 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 BALS.;;.(define
04d0: 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 0a 28 *verbosity* 1).(
04e0: 64 65 66 69 6e 65 20 2a 6c 6f 67 67 69 6e 67 2a define *logging*
04f0: 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a 65 78 #f).(define *ex
0500: 65 2d 6e 61 6d 65 2a 20 28 70 61 74 68 6e 61 6d e-name* (pathnam
0510: 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 67 e-file (car (arg
0520: 76 29 29 29 29 0a 28 64 65 66 69 6e 65 20 2a 73 v)))).(define *s
0530: 72 65 74 72 69 65 76 65 3a 63 75 72 72 65 6e 74 retrieve:current
0540: 2d 74 61 62 2d 6e 75 6d 62 65 72 2a 20 30 29 0a -tab-number* 0).
0550: 28 64 65 66 69 6e 65 20 2a 61 72 67 73 2d 68 61 (define *args-ha
0560: 73 68 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 sh* (make-hash-t
0570: 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 73 able)).(define s
0580: 61 75 74 68 6f 72 69 7a 65 3a 68 65 6c 70 20 28 authorize:help (
0590: 63 6f 6e 63 20 22 55 73 61 67 65 3a 20 22 20 2a conc "Usage: " *
05a0: 65 78 65 2d 6e 61 6d 65 2a 20 22 20 5b 61 63 74 exe-name* " [act
05b0: 69 6f 6e 20 5b 70 61 72 61 6d 73 20 2e 2e 2e 5d ion [params ...]
05c0: 5d 0a 0a 20 20 6c 69 73 74 20 20 20 20 20 20 20 ].. list
05d0: 20 20 20 20 20 20 20 20 20 20 20 20 09 09 20 09 .. .
05e0: 09 09 3a 20 6c 69 73 74 20 61 72 65 61 73 20 24 ..: list areas $
05f0: 55 53 45 52 27 73 20 63 61 6e 20 61 63 63 65 73 USER's can acces
0600: 73 0a 20 20 6c 6f 67 20 20 20 20 20 20 20 20 20 s. log
0610: 20 20 20 20 20 20 20 20 20 20 20 09 09 20 09 09 .. ..
0620: 09 3a 20 67 65 74 20 6c 69 73 74 69 6e 67 20 6f .: get listing o
0630: 66 20 72 65 63 65 6e 74 20 61 63 74 69 76 69 74 f recent activit
0640: 79 2e 0a 20 20 73 61 75 74 68 20 20 6c 69 73 74 y.. sauth list
0650: 2d 61 72 65 61 2d 75 73 65 72 20 3c 61 72 65 61 -area-user <area
0660: 20 63 6f 64 65 3e 20 09 09 09 3a 20 6c 69 73 74 code> ...: list
0670: 20 74 68 65 20 75 73 65 72 73 20 74 68 61 74 20 the users that
0680: 63 61 6e 20 61 63 63 65 73 73 20 74 68 65 20 61 can access the a
0690: 72 65 61 2e 0a 20 20 73 61 75 74 68 20 6f 70 65 rea.. sauth ope
06a0: 6e 20 3c 70 61 74 68 3e 20 2d 2d 67 72 6f 75 70 n <path> --group
06b0: 20 3c 67 72 70 6e 61 6d 65 3e 20 20 20 20 20 20 <grpname>
06c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06d0: 3a 20 4f 70 65 6e 20 75 70 20 61 6e 20 61 72 65 : Open up an are
06e0: 61 2e 20 55 73 65 72 20 6e 65 65 64 73 20 74 6f a. User needs to
06f0: 20 62 65 20 74 68 65 20 6f 77 6e 65 72 20 6f 66 be the owner of
0700: 20 74 68 65 20 61 72 65 61 20 74 6f 20 6f 70 65 the area to ope
0710: 6e 20 69 74 2e 20 0a 20 20 20 20 20 20 20 20 20 n it. .
0720: 20 20 20 20 20 2d 2d 63 6f 64 65 20 3c 75 6e 69 --code <uni
0730: 71 75 65 20 73 68 6f 72 74 20 69 64 65 6e 74 69 que short identi
0740: 66 69 65 72 20 66 6f 72 20 61 6e 20 61 72 65 61 fier for an area
0750: 3e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 > .
0760: 20 2d 2d 72 65 74 72 69 65 76 65 7c 2d 2d 70 75 --retrieve|--pu
0770: 62 6c 69 73 68 20 5b 2d 2d 61 64 64 69 74 69 6f blish [--additio
0780: 6e 61 6c 2d 67 72 70 73 20 3c 63 6f 6d 6d 61 20 nal-grps <comma
0790: 73 65 70 61 72 61 74 65 64 20 75 6e 69 78 20 67 separated unix g
07a0: 72 70 73 20 72 65 71 75 69 65 72 64 20 74 6f 20 rps requierd to
07b0: 67 65 74 20 74 6f 20 74 68 65 20 70 61 74 68 3e get to the path>
07c0: 5d 0a 20 20 73 61 75 74 68 20 75 70 64 61 74 65 ]. sauth update
07d0: 20 3c 61 72 65 61 20 63 6f 64 65 3e 20 20 2d 2d <area code> --
07e0: 72 65 74 72 69 65 76 65 7c 2d 2d 70 75 62 6c 69 retrieve|--publi
07f0: 73 68 20 20 20 20 20 20 20 20 20 20 20 20 20 3a sh :
0800: 20 75 70 64 61 74 65 20 74 68 65 20 62 69 6e 61 update the bina
0810: 72 69 65 73 20 77 69 74 68 20 74 68 65 20 6c 61 ries with the la
0820: 74 65 73 20 63 68 61 6e 67 65 73 0a 20 20 73 61 tes changes. sa
0830: 75 74 68 20 67 72 61 6e 74 20 3c 75 73 65 72 6e uth grant <usern
0840: 61 6d 65 3e 20 2d 2d 61 72 65 61 20 3c 61 72 65 ame> --area <are
0850: 61 20 69 64 65 6e 74 69 66 69 65 72 3e 20 20 20 a identifier>
0860: 20 20 20 20 20 20 20 3a 20 47 72 61 6e 74 20 70 : Grant p
0870: 65 72 6d 69 73 73 69 6f 6e 20 74 6f 20 72 65 61 ermission to rea
0880: 64 20 6f 72 20 77 72 69 74 65 20 74 6f 20 61 20 d or write to a
0890: 61 72 65 61 20 74 68 61 74 20 69 73 20 61 6c 72 area that is alr
08a0: 61 64 79 20 6f 70 65 6e 64 20 75 70 2e 20 20 20 ady opend up.
08b0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 2d . -
08c0: 2d 65 78 70 69 72 61 74 69 6f 6e 20 79 79 79 79 -expiration yyyy
08d0: 2f 6d 6d 2f 64 64 20 2d 2d 72 65 74 72 69 65 76 /mm/dd --retriev
08e0: 65 7c 2d 2d 70 75 62 6c 69 73 68 20 0a 20 20 20 e|--publish .
08f0: 20 20 20 20 20 20 20 20 20 20 5b 2d 2d 72 65 73 [--res
0900: 74 72 69 63 74 20 3c 63 6f 6d 6d 61 20 73 65 70 trict <comma sep
0910: 61 72 61 74 65 64 20 64 69 72 65 63 74 6f 72 79 arated directory
0920: 20 6e 61 6d 65 73 3e 20 5d 20 20 0a 20 20 73 61 names> ] . sa
0930: 75 74 68 20 72 65 61 64 2d 73 68 65 6c 6c 20 3c uth read-shell <
0940: 61 72 65 61 20 69 64 65 6e 74 69 66 69 65 72 3e area identifier>
0950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0960: 20 20 20 20 20 20 20 3a 20 20 4f 70 65 6e 20 73 : Open s
0970: 72 65 74 72 69 65 76 65 20 73 68 65 6c 6c 20 66 retrieve shell f
0980: 6f 72 20 72 65 61 64 69 6e 67 2e 20 20 0a 20 20 or reading. .
0990: 73 61 75 74 68 20 77 72 69 74 65 2d 73 68 65 6c sauth write-shel
09a0: 6c 20 3c 61 72 65 61 20 69 64 65 6e 74 69 66 69 l <area identifi
09b0: 65 72 3e 20 20 20 20 20 20 20 20 20 20 20 20 20 er>
09c0: 20 20 20 20 20 20 20 20 20 3a 20 20 4f 70 65 6e : Open
09d0: 20 73 70 75 62 6c 69 73 68 20 73 68 65 6c 6c 20 spublish shell
09e0: 66 6f 72 20 77 72 69 74 69 6e 67 2e 0a 20 20 20 for writing..
09f0: 0a 50 61 72 74 20 6f 66 20 74 68 65 20 4d 65 67 .Part of the Meg
0a00: 61 74 65 73 74 20 74 6f 6f 6c 20 73 75 69 74 65 atest tool suite
0a10: 2e 0a 4c 65 61 72 6e 20 6d 6f 72 65 20 61 74 20 ..Learn more at
0a20: 68 74 74 70 3a 2f 2f 77 77 77 2e 6b 69 61 74 6f http://www.kiato
0a30: 61 2e 63 6f 6d 2f 66 6f 73 73 69 6c 73 2f 6d 65 a.com/fossils/me
0a40: 67 61 74 65 73 74 0a 0a 56 65 72 73 69 6f 6e 3a gatest..Version:
0a50: 20 22 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 " megatest-foss
0a60: 69 6c 2d 68 61 73 68 29 29 20 3b 3b 20 22 0a 0a il-hash)) ;; "..
0a70: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ab0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 45 43 4f ========.;; RECO
0ac0: 52 44 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d RDS.;;==========
0ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
0b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b50: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 42 0a 3b 3b 3d ======.;; DB.;;=
0b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ba0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 72 65 70 6c 61 63 =====..;; replac
0bb0: 65 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 e (strftime('%s'
0bc0: 2c 27 6e 6f 77 27 29 29 2c 20 77 69 74 68 20 64 ,'now')), with d
0bd0: 61 74 65 74 69 6d 65 28 27 6e 6f 77 27 29 29 0a atetime('now')).
0be0: 28 64 65 66 69 6e 65 20 28 73 61 75 74 68 6f 72 (define (sauthor
0bf0: 69 7a 65 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 64 ize:initialize-d
0c00: 62 20 64 62 29 0a 20 20 28 66 6f 72 2d 65 61 63 b db). (for-eac
0c10: 68 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 71 72 h. (lambda (qr
0c20: 79 29 0a 20 20 20 20 20 28 65 78 65 63 20 28 73 y). (exec (s
0c30: 71 6c 20 64 62 20 71 72 79 29 29 29 0a 20 20 20 ql db qry))).
0c40: 28 6c 69 73 74 20 0a 20 20 20 20 22 43 52 45 41 (list . "CREA
0c50: 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 TE TABLE IF NOT
0c60: 45 58 49 53 54 53 20 61 63 74 69 6f 6e 73 0a 20 EXISTS actions.
0c70: 20 20 20 20 20 20 20 20 28 69 64 20 20 20 20 20 (id
0c80: 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 INTEGER PR
0c90: 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 IMARY KEY,.
0ca0: 20 20 20 20 20 63 6d 64 20 20 20 20 20 20 20 54 cmd T
0cb0: 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 EXT NOT NULL,.
0cc0: 20 20 20 20 20 20 20 20 75 73 65 72 5f 69 64 20 user_id
0cd0: 20 20 20 20 20 49 4e 54 45 47 45 52 20 4e 4f 54 INTEGER NOT
0ce0: 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 NULL,.
0cf0: 20 64 61 74 65 74 69 6d 65 20 20 20 20 20 54 49 datetime TI
0d00: 4d 45 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 MESTAMP DEFAULT
0d10: 28 64 61 74 65 74 69 6d 65 28 27 6e 6f 77 27 2c (datetime('now',
0d20: 27 6c 6f 63 61 6c 74 69 6d 65 27 29 29 2c 0a 20 'localtime')),.
0d30: 20 20 20 20 20 20 20 20 20 61 72 65 61 5f 69 64 area_id
0d40: 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 4e 4f INTEGER NO
0d50: 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 T NULL,.
0d60: 20 20 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 54 comment T
0d70: 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 20 4e EXT DEFAULT '' N
0d80: 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 OT NULL,.
0d90: 20 20 20 61 63 74 69 6f 6e 5f 74 79 70 65 20 20 action_type
0da0: 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 29 3b 22 TEXT NOT NULL);"
0db0: 0a 20 20 20 20 20 20 20 20 22 43 52 45 41 54 45 . "CREATE
0dc0: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
0dd0: 49 53 54 53 20 75 73 65 72 73 0a 20 20 20 20 20 ISTS users.
0de0: 20 20 20 20 28 69 64 20 20 20 20 20 20 20 20 20 (id
0df0: 20 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 INTEGER PRIMAR
0e00: 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 Y KEY,.
0e10: 20 75 73 65 72 6e 61 6d 65 20 20 20 20 20 54 45 username TE
0e20: 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 XT NOT NULL,.
0e30: 20 20 20 20 20 20 20 69 73 5f 61 64 6d 69 6e 20 is_admin
0e40: 20 20 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c TEXT NOT NUL
0e50: 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 64 61 74 L,. dat
0e60: 65 74 69 6d 65 20 20 20 20 20 54 49 4d 45 53 54 etime TIMEST
0e70: 41 4d 50 20 44 45 46 41 55 4c 54 20 28 64 61 74 AMP DEFAULT (dat
0e80: 65 74 69 6d 65 28 27 6e 6f 77 27 2c 27 6c 6f 63 etime('now','loc
0e90: 61 6c 74 69 6d 65 27 29 29 0a 20 20 20 20 20 20 altime')).
0ea0: 20 20 20 20 29 3b 22 20 0a 20 20 20 20 20 20 20 );" .
0eb0: 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 "CREATE TABLE
0ec0: 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 61 IF NOT EXISTS a
0ed0: 72 65 61 73 0a 20 20 20 20 20 20 20 20 20 28 69 reas. (i
0ee0: 64 20 20 20 20 20 20 20 20 20 20 20 49 4e 54 45 d INTE
0ef0: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
0f00: 0a 20 20 20 20 20 20 20 20 20 20 62 61 73 65 70 . basep
0f10: 61 74 68 20 20 20 20 20 54 45 58 54 20 4e 4f 54 ath TEXT NOT
0f20: 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 NULL,.
0f30: 20 63 6f 64 65 20 20 20 20 20 20 20 20 20 54 45 code TE
0f40: 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 XT NOT NULL,.
0f50: 20 20 20 20 20 20 20 65 78 65 5f 6e 61 6d 65 20 exe_name
0f60: 20 20 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c TEXT NOT NUL
0f70: 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 72 65 71 L,. req
0f80: 75 69 72 65 64 5f 67 72 70 73 20 54 45 58 54 20 uired_grps TEXT
0f90: 44 45 46 41 55 4c 54 20 27 27 20 4e 4f 54 20 4e DEFAULT '' NOT N
0fa0: 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 64 ULL,. d
0fb0: 61 74 65 74 69 6d 65 20 20 20 20 20 54 49 4d 45 atetime TIME
0fc0: 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 28 64 STAMP DEFAULT (d
0fd0: 61 74 65 74 69 6d 65 28 27 6e 6f 77 27 2c 27 6c atetime('now','l
0fe0: 6f 63 61 6c 74 69 6d 65 27 29 29 0a 20 20 20 20 ocaltime')).
0ff0: 20 20 20 20 20 20 29 3b 22 20 0a 20 20 20 20 20 );" .
1000: 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c "CREATE TABL
1010: 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 E IF NOT EXISTS
1020: 70 65 72 6d 69 73 73 69 6f 6e 73 0a 20 20 20 20 permissions.
1030: 20 20 20 20 20 28 69 64 20 20 20 20 20 20 20 20 (id
1040: 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 INTEGER PR
1050: 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 IMARY KEY,.
1060: 20 20 20 20 20 61 63 63 65 73 73 5f 74 79 70 65 access_type
1070: 20 20 20 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 TEXT NOT NU
1080: 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 75 73 LL,. us
1090: 65 72 5f 69 64 20 20 20 20 20 20 20 20 20 49 4e er_id IN
10a0: 54 45 47 45 52 20 4e 4f 54 20 4e 55 4c 4c 2c 0a TEGER NOT NULL,.
10b0: 20 20 20 20 20 20 20 20 20 20 64 61 74 65 74 69 dateti
10c0: 6d 65 20 20 20 20 20 20 20 20 54 49 4d 45 53 54 me TIMEST
10d0: 41 4d 50 20 44 45 46 41 55 4c 54 20 28 64 61 74 AMP DEFAULT (dat
10e0: 65 74 69 6d 65 28 27 6e 6f 77 27 2c 27 6c 6f 63 etime('now','loc
10f0: 61 6c 74 69 6d 65 27 29 29 2c 0a 20 20 20 20 20 altime')),.
1100: 20 20 20 20 20 61 72 65 61 5f 69 64 20 20 20 20 area_id
1110: 20 20 20 20 20 49 4e 54 45 47 45 52 20 4e 4f 54 INTEGER NOT
1120: 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 NULL,.
1130: 20 72 65 73 74 72 69 63 74 69 6f 6e 20 20 20 20 restriction
1140: 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 TEXT DEFAULT ''
1150: 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 NOT NULL,.
1160: 20 20 20 20 20 65 78 70 69 72 61 74 69 6f 6e 20 expiration
1170: 20 20 20 20 20 20 54 49 4d 45 53 54 41 4d 50 20 TIMESTAMP
1180: 44 45 46 41 55 4c 54 20 4e 55 4c 4c 29 3b 22 0a DEFAULT NULL);".
1190: 20 20 20 20 29 29 29 0a 0a 0a 0a 0a 28 64 65 66 ))).....(def
11a0: 69 6e 65 20 28 67 65 74 2d 61 63 63 65 73 73 2d ine (get-access-
11b0: 74 79 70 65 20 61 72 67 73 29 0a 20 20 20 28 6c type args). (l
11c0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
11d0: 61 72 20 61 72 67 73 29 29 0a 09 09 20 28 74 61 ar args))... (ta
11e0: 6c 20 28 63 64 72 20 61 72 67 73 29 29 29 0a 20 l (cdr args))).
11f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1200: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
1210: 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 75 ((equ
1220: 61 6c 3f 20 68 65 64 20 22 2d 2d 72 65 74 72 69 al? hed "--retri
1230: 65 76 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 eve").
1240: 20 20 20 20 20 20 20 20 20 20 20 20 22 72 65 74 "ret
1250: 72 69 65 76 65 22 29 20 0a 20 20 20 20 20 20 20 rieve") .
1260: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 ((eq
1270: 75 61 6c 3f 20 68 65 64 20 22 2d 2d 70 75 62 6c ual? hed "--publ
1280: 69 73 68 22 29 0a 20 20 20 20 20 20 20 20 20 20 ish").
1290: 20 20 20 20 20 20 20 20 20 20 20 20 22 70 75 62 "pub
12a0: 6c 69 73 68 22 29 20 0a 20 20 20 20 20 20 20 20 lish") .
12b0: 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 75 ((equ
12c0: 61 6c 3f 20 68 65 64 20 22 2d 2d 61 72 65 61 2d al? hed "--area-
12d0: 61 64 6d 69 6e 22 29 0a 20 20 20 20 20 20 20 20 admin").
12e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 61 "a
12f0: 72 65 61 2d 61 64 6d 69 6e 22 29 0a 20 20 20 20 rea-admin").
1300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1310: 28 65 71 75 61 6c 3f 20 68 65 64 20 22 2d 2d 77 (equal? hed "--w
1320: 72 69 74 65 72 2d 61 64 6d 69 6e 22 29 0a 20 20 riter-admin").
1330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1340: 20 20 20 20 22 77 72 69 74 65 72 2d 61 64 6d 69 "writer-admi
1350: 6e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 n").
1360: 20 20 20 20 20 20 20 28 28 65 71 75 61 6c 3f 20 ((equal?
1370: 68 65 64 20 22 2d 2d 72 65 61 64 2d 61 64 6d 69 hed "--read-admi
1380: 6e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 n").
1390: 20 20 20 20 20 20 20 20 20 20 22 72 65 61 64 2d "read-
13a0: 61 64 6d 69 6e 22 29 0a 0a 20 20 20 20 20 20 20 admin")..
13b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 ((nu
13c0: 6c 6c 3f 20 74 61 6c 29 0a 20 20 20 20 20 20 20 ll? tal).
13d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
13e0: 66 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 f) .
13f0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 (else ...
1400: 20 20 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 .(loop (car ta
1410: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
1420: 0a 0a 0a 0a 3b 3b 20 63 68 65 63 6b 20 69 66 20 ....;; check if
1430: 75 73 65 72 20 63 61 6e 20 67 72 61 6e 20 61 63 user can gran ac
1440: 63 65 73 73 20 74 6f 20 61 6e 20 61 72 65 61 0a cess to an area.
1450: 28 64 65 66 69 6e 65 20 28 63 61 6e 2d 67 72 61 (define (can-gra
1460: 6e 74 2d 70 65 72 6d 20 75 73 65 72 6e 61 6d 65 nt-perm username
1470: 20 61 63 63 65 73 73 2d 74 79 70 65 20 61 72 65 access-type are
1480: 61 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 69 73 a). (let* ((is
1490: 61 64 6d 69 6e 20 28 69 73 2d 61 64 6d 69 6e 20 admin (is-admin
14a0: 75 73 65 72 6e 61 6d 65 29 29 0a 20 20 20 20 20 username)).
14b0: 20 20 20 20 20 28 69 73 2d 61 72 65 61 2d 61 64 (is-area-ad
14c0: 6d 69 6e 20 28 69 73 2d 75 73 65 72 20 22 61 72 min (is-user "ar
14d0: 65 61 2d 61 64 6d 69 6e 22 20 75 73 65 72 6e 61 ea-admin" userna
14e0: 6d 65 20 61 72 65 61 20 29 29 0a 20 20 20 20 20 me area )).
14f0: 20 20 20 20 20 28 69 73 2d 72 65 61 64 2d 61 64 (is-read-ad
1500: 6d 69 6e 20 28 69 73 2d 75 73 65 72 20 22 72 65 min (is-user "re
1510: 61 64 2d 61 64 6d 69 6e 22 20 75 73 65 72 6e 61 ad-admin" userna
1520: 6d 65 20 61 72 65 61 29 20 29 0a 20 20 20 20 20 me area) ).
1530: 20 20 20 20 20 28 69 73 2d 77 72 69 74 65 72 2d (is-writer-
1540: 61 64 6d 69 6e 20 28 69 73 2d 75 73 65 72 20 22 admin (is-user "
1550: 77 72 69 74 65 72 2d 61 64 6d 69 6e 22 20 75 73 writer-admin" us
1560: 65 72 6e 61 6d 65 20 61 72 65 61 29 20 29 20 29 ername area) ) )
1570: 0a 20 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 65 . (cond. ((e
1580: 71 75 61 6c 3f 20 69 73 61 64 6d 69 6e 20 20 23 qual? isadmin #
1590: 74 29 0a 20 20 20 20 20 23 74 29 0a 20 20 20 28 t). #t). (
15a0: 28 65 71 75 61 6c 3f 20 69 73 2d 61 72 65 61 2d (equal? is-area-
15b0: 61 64 6d 69 6e 20 23 74 20 29 20 0a 20 20 20 20 admin #t ) .
15c0: 20 23 74 29 0a 20 20 20 28 28 61 6e 64 20 28 65 #t). ((and (e
15d0: 71 75 61 6c 3f 20 69 73 2d 77 72 69 74 65 72 2d qual? is-writer-
15e0: 61 64 6d 69 6e 20 23 74 20 29 20 28 65 71 75 61 admin #t ) (equa
15f0: 6c 3f 20 61 63 63 65 73 73 2d 74 79 70 65 20 22 l? access-type "
1600: 72 65 74 72 69 65 76 65 22 29 29 0a 20 20 20 20 retrieve")).
1610: 20 23 74 29 0a 20 20 20 28 28 61 6e 64 20 28 65 #t). ((and (e
1620: 71 75 61 6c 3f 20 69 73 2d 72 65 61 64 2d 61 64 qual? is-read-ad
1630: 6d 69 6e 20 23 74 20 29 20 28 65 71 75 61 6c 3f min #t ) (equal?
1640: 20 61 63 63 65 73 73 2d 74 79 70 65 20 22 72 65 access-type "re
1650: 74 72 69 65 76 65 22 29 29 0a 20 20 20 20 20 23 trieve")). #
1660: 74 29 0a 0a 20 20 20 28 65 6c 73 65 20 20 0a 20 t).. (else .
1670: 20 20 20 23 66 29 29 29 29 0a 0a 28 64 65 66 69 #f))))..(defi
1680: 6e 65 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 6c ne (sauthorize:l
1690: 69 73 74 2d 61 72 65 61 75 73 65 72 73 20 20 61 ist-areausers a
16a0: 72 65 61 20 29 0a 20 20 28 73 61 75 74 68 6f 72 rea ). (sauthor
16b0: 69 7a 65 3a 64 62 2d 64 6f 20 20 28 6c 61 6d 62 ize:db-do (lamb
16c0: 64 61 20 28 64 62 29 0a 09 09 09 09 20 20 20 20 da (db).....
16d0: 20 28 70 72 69 6e 74 20 22 55 73 65 72 73 20 68 (print "Users h
16e0: 61 76 69 6e 67 20 61 63 63 65 73 73 20 74 6f 20 aving access to
16f0: 22 20 61 72 65 61 20 22 3a 22 29 0a 09 09 09 09 " area ":").....
1700: 20 20 20 20 20 28 71 75 65 72 79 20 28 66 6f 72 (query (for
1710: 2d 65 61 63 68 2d 72 6f 77 0a 09 09 09 09 09 20 -each-row......
1720: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 6f 77 (lambda (row
1730: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1760: 20 28 6c 65 74 2a 20 28 28 65 78 70 2d 64 61 74 (let* ((exp-dat
1770: 65 20 28 63 61 64 72 20 72 6f 77 29 29 29 0a 20 e (cadr row))).
1780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
17b0: 69 66 20 20 28 69 73 2d 61 63 63 65 73 73 2d 76 if (is-access-v
17c0: 61 6c 69 64 20 20 65 78 70 2d 64 61 74 65 29 20 alid exp-date)
17d0: 20 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 20 ......
17e0: 28 61 70 70 6c 79 20 70 72 69 6e 74 20 28 69 6e (apply print (in
17f0: 74 65 72 73 70 65 72 73 65 20 72 6f 77 20 22 20 tersperse row "
1800: 7c 20 22 29 29 29 29 29 29 0a 09 09 09 09 09 20 | "))))))......
1810: 20 20 20 28 73 71 6c 20 64 62 20 28 63 6f 6e 63 (sql db (conc
1820: 20 22 53 45 4c 45 43 54 20 75 73 65 72 73 2e 75 "SELECT users.u
1830: 73 65 72 6e 61 6d 65 2c 20 70 65 72 6d 69 73 73 sername, permiss
1840: 69 6f 6e 73 2e 65 78 70 69 72 61 74 69 6f 6e 2c ions.expiration,
1850: 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 61 63 63 permissions.acc
1860: 65 73 73 5f 74 79 70 65 20 20 46 52 4f 4d 20 75 ess_type FROM u
1870: 73 65 72 73 2c 20 61 72 65 61 73 2c 20 70 65 72 sers, areas, per
1880: 6d 69 73 73 69 6f 6e 73 20 77 68 65 72 65 20 70 missions where p
1890: 65 72 6d 69 73 73 69 6f 6e 73 2e 75 73 65 72 5f ermissions.user_
18a0: 69 64 20 3d 20 75 73 65 72 73 2e 69 64 20 61 6e id = users.id an
18b0: 64 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 61 72 d permissions.ar
18c0: 65 61 5f 69 64 20 3d 20 61 72 65 61 73 2e 69 64 ea_id = areas.id
18d0: 20 61 6e 64 20 61 72 65 61 73 2e 63 6f 64 65 20 and areas.code
18e0: 3d 20 27 22 20 61 72 65 61 20 22 27 22 29 29 29 = '" area "'")))
18f0: 29 29 29 0a 0a 0a 0a 0a 3b 20 63 68 65 63 6b 20 ))).....; check
1900: 69 66 20 65 78 65 63 75 74 61 62 6c 65 20 65 78 if executable ex
1910: 69 73 74 73 0a 28 64 65 66 69 6e 65 20 28 65 78 ists.(define (ex
1920: 65 2d 65 78 69 73 74 20 65 78 65 20 61 63 63 65 e-exist exe acce
1930: 73 73 2d 74 79 70 65 29 0a 20 20 20 20 28 6c 65 ss-type). (le
1940: 74 2a 20 28 28 66 69 6c 65 70 61 74 68 20 28 63 t* ((filepath (c
1950: 6f 6e 63 20 2a 65 78 65 2d 70 61 74 68 2a 20 22 onc *exe-path* "
1960: 2f 22 20 61 63 63 65 73 73 2d 74 79 70 65 20 22 /" access-type "
1970: 2f 22 20 65 78 65 29 29 29 0a 20 20 20 20 3b 20 /" exe))). ;
1980: 28 70 72 69 6e 74 20 66 69 6c 65 70 61 74 68 29 (print filepath)
1990: 0a 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d . (if (file-
19a0: 65 78 69 73 74 73 3f 20 66 69 6c 65 70 61 74 68 exists? filepath
19b0: 29 0a 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 ). #t.
19c0: 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e #f)))..(defin
19d0: 65 20 28 63 6f 70 79 2d 65 78 65 20 61 63 63 65 e (copy-exe acce
19e0: 73 73 2d 74 79 70 65 20 65 78 65 2d 6e 61 6d 65 ss-type exe-name
19f0: 20 67 72 6f 75 70 29 0a 20 20 28 72 75 6e 2d 63 group). (run-c
1a00: 6d 64 20 22 2f 62 69 6e 2f 63 68 6d 6f 64 22 20 md "/bin/chmod"
1a10: 28 6c 69 73 74 20 22 67 2b 77 22 20 28 63 6f 6e (list "g+w" (con
1a20: 63 20 2a 65 78 65 2d 70 61 74 68 2a 20 22 2f 22 c *exe-path* "/"
1a30: 20 61 63 63 65 73 73 2d 74 79 70 65 29 29 29 0a access-type))).
1a40: 20 20 28 6c 65 74 2a 20 28 28 73 70 61 74 68 20 (let* ((spath
1a50: 28 63 6f 6e 63 20 2a 65 78 65 2d 73 72 63 2a 20 (conc *exe-src*
1a60: 20 22 2f 73 22 20 61 63 63 65 73 73 2d 74 79 70 "/s" access-typ
1a70: 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 64 70 e)). (dp
1a80: 61 74 68 20 28 63 6f 6e 63 20 2a 65 78 65 2d 70 ath (conc *exe-p
1a90: 61 74 68 2a 20 22 2f 22 20 61 63 63 65 73 73 2d ath* "/" access-
1aa0: 74 79 70 65 20 22 2f 22 20 65 78 65 2d 6e 61 6d type "/" exe-nam
1ab0: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 e))). (s
1ac0: 61 75 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d authorize:do-as-
1ad0: 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 calling-user.
1ae0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
1af0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e (run
1b00: 2d 63 6d 64 20 22 2f 62 69 6e 2f 63 70 22 20 28 -cmd "/bin/cp" (
1b10: 6c 69 73 74 20 73 70 61 74 68 20 64 70 61 74 68 list spath dpath
1b20: 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 )) .
1b30: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 61 63 63 (if (equal? acc
1b40: 65 73 73 2d 74 79 70 65 20 22 70 75 62 6c 69 73 ess-type "publis
1b50: 68 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h").
1b60: 20 20 28 72 75 6e 2d 63 6d 64 20 22 2f 62 69 6e (run-cmd "/bin
1b70: 2f 63 68 6d 6f 64 22 20 28 6c 69 73 74 20 22 75 /chmod" (list "u
1b80: 2b 73 2c 6f 2b 72 78 22 20 64 70 61 74 68 29 29 +s,o+rx" dpath))
1b90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
1ba0: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
1bb0: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
1bc0: 20 67 72 6f 75 70 20 22 6e 6f 6e 65 22 29 0a 20 group "none").
1bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1be0: 28 72 75 6e 2d 63 6d 64 20 22 2f 62 69 6e 2f 63 (run-cmd "/bin/c
1bf0: 68 6d 6f 64 22 20 28 6c 69 73 74 20 22 75 2b 73 hmod" (list "u+s
1c00: 2c 6f 2b 72 78 22 20 64 70 61 74 68 29 29 0a 20 ,o+rx" dpath)).
1c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c20: 28 62 65 67 69 6e 20 20 20 0a 20 20 20 20 20 20 (begin .
1c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1c40: 72 75 6e 2d 63 6d 64 20 22 2f 62 69 6e 2f 63 68 run-cmd "/bin/ch
1c50: 67 72 70 22 20 28 6c 69 73 74 20 67 72 6f 75 70 grp" (list group
1c60: 20 64 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 dpath)).
1c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c80: 28 72 75 6e 2d 63 6d 64 20 22 2f 62 69 6e 2f 63 (run-cmd "/bin/c
1c90: 68 6d 6f 64 22 20 28 6c 69 73 74 20 22 67 2b 73 hmod" (list "g+s
1ca0: 2c 6f 2b 72 78 22 20 64 70 61 74 68 29 29 29 29 ,o+rx" dpath))))
1cb0: 29 29 29 29 0a 09 28 72 75 6e 2d 63 6d 64 20 22 ))))..(run-cmd "
1cc0: 63 68 6d 6f 64 22 20 28 6c 69 73 74 20 22 67 2d chmod" (list "g-
1cd0: 77 22 20 28 63 6f 6e 63 20 2a 65 78 65 2d 70 61 w" (conc *exe-pa
1ce0: 74 68 2a 20 22 2f 22 20 61 63 63 65 73 73 2d 74 th* "/" access-t
1cf0: 79 70 65 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ype)))))..(defin
1d00: 65 20 28 67 65 74 2d 65 78 65 2d 6e 61 6d 65 20 e (get-exe-name
1d10: 70 61 74 68 20 67 72 6f 75 70 29 0a 20 20 20 28 path group). (
1d20: 6c 65 74 20 28 28 6e 61 6d 65 20 22 22 29 29 0a let ((name "")).
1d30: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
1d40: 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 o-as-calling-use
1d50: 72 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 r. (lambd
1d60: 61 20 28 29 0a 20 20 20 20 20 20 20 20 28 69 66 a (). (if
1d70: 20 28 65 71 75 61 6c 3f 20 28 63 75 72 72 65 6e (equal? (curren
1d80: 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 65 72 t-effective-user
1d90: 2d 69 64 29 20 28 66 69 6c 65 2d 6f 77 6e 65 72 -id) (file-owner
1da0: 20 70 61 74 68 29 29 20 0a 20 20 20 20 20 20 20 path)) .
1db0: 20 20 20 28 73 65 74 21 20 6e 61 6d 65 20 28 63 (set! name (c
1dc0: 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 75 73 65 onc (current-use
1dd0: 72 2d 6e 61 6d 65 29 20 22 5f 22 20 67 72 6f 75 r-name) "_" grou
1de0: 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 62 p)). (b
1df0: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
1e00: 20 28 70 72 69 6e 74 20 22 59 6f 75 20 63 61 6e (print "You can
1e10: 6e 6f 74 20 6f 70 65 6e 20 61 72 65 61 73 20 74 not open areas t
1e20: 68 61 74 20 79 6f 75 20 64 6f 6e 74 20 6f 77 6e hat you dont own
1e30: 21 21 22 29 20 20 0a 20 20 20 20 20 20 20 20 20 !!") .
1e40: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 29 (exit 1)))))
1e50: 0a 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 .name))..(define
1e60: 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 76 61 6c (sauthorize:val
1e70: 69 64 2d 75 6e 69 78 2d 75 73 65 72 20 75 73 65 id-unix-user use
1e80: 72 6e 61 6d 65 29 0a 20 20 20 20 28 6c 65 74 2a rname). (let*
1e90: 20 28 28 72 65 74 2d 76 61 6c 20 23 66 29 29 0a ((ret-val #f)).
1ea0: 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 (let-values
1eb0: 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 0a (((inp oup pid).
1ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
1ed0: 72 6f 63 65 73 73 20 22 2f 75 73 72 2f 62 69 6e rocess "/usr/bin
1ee0: 2f 69 64 22 20 28 6c 69 73 74 20 75 73 65 72 6e /id" (list usern
1ef0: 61 6d 65 29 29 29 29 0a 20 20 20 20 20 20 20 20 ame)))).
1f00: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 (let loop ((inl
1f10: 28 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 29 29 (read-line inp))
1f20: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
1f30: 28 73 74 72 69 6e 67 3f 20 69 6e 6c 29 20 0a 20 (string? inl) .
1f40: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 73 74 (if (st
1f50: 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 20 69 6e ring-contains in
1f60: 6c 20 20 22 4e 6f 20 73 75 63 68 20 75 73 65 72 l "No such user
1f70: 22 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 ") .
1f80: 28 73 65 74 21 20 72 65 74 2d 76 61 6c 20 23 66 (set! ret-val #f
1f90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
1fa0: 73 65 74 21 20 72 65 74 2d 76 61 6c 20 23 74 29 set! ret-val #t)
1fb0: 29 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 )) .
1fc0: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
1fd0: 20 69 6e 6c 29 0a 20 20 20 20 20 20 20 20 20 20 inl).
1fe0: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
1ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2000: 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 lose-input-port
2010: 69 6e 70 29 0a 20 20 20 20 20 20 20 20 20 20 20 inp).
2020: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 (close-ou
2030: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 0a tput-port oup)).
2040: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
2050: 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 p (read-line inp
2060: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))).
2070: 20 20 72 65 74 2d 76 61 6c 29 29 0a 0a 0a 3b 63 ret-val))...;c
2080: 68 65 63 6b 20 69 66 20 61 20 70 61 74 68 73 2f heck if a paths/
2090: 63 6f 64 65 73 20 61 72 65 20 76 61 69 64 20 61 codes are vaid a
20a0: 6e 64 20 69 66 20 61 72 65 61 20 69 73 20 61 6c nd if area is al
20b0: 72 61 64 79 20 6f 70 65 6e 20 20 0a 28 64 65 66 rady open .(def
20c0: 69 6e 65 20 28 6f 70 65 6e 2d 61 72 65 61 20 67 ine (open-area g
20d0: 72 6f 75 70 20 70 61 74 68 20 63 6f 64 65 20 61 roup path code a
20e0: 63 63 65 73 73 2d 74 79 70 65 20 6f 74 68 65 72 ccess-type other
20f0: 2d 67 72 70 73 29 0a 20 20 20 28 6c 65 74 2a 20 -grps). (let*
2100: 28 28 65 78 65 2d 6e 61 6d 65 20 28 67 65 74 2d ((exe-name (get-
2110: 65 78 65 2d 6e 61 6d 65 20 70 61 74 68 20 67 72 exe-name path gr
2120: 6f 75 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 oup)).
2130: 20 28 70 61 74 68 2d 6f 62 6a 20 28 67 65 74 2d (path-obj (get-
2140: 6f 62 6a 2d 62 79 2d 70 61 74 68 20 70 61 74 68 obj-by-path path
2150: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 63 )). (c
2160: 6f 64 65 2d 6f 62 6a 20 28 67 65 74 2d 6f 62 6a ode-obj (get-obj
2170: 2d 62 79 2d 63 6f 64 65 2d 6e 6f 2d 67 72 70 2d -by-code-no-grp-
2180: 76 61 6c 69 64 61 74 69 6f 6e 20 63 6f 64 65 29 validation code)
2190: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 3b 28 )). ;(
21a0: 70 72 69 6e 74 20 70 61 74 68 2d 6f 62 6a 29 20 print path-obj)
21b0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f . (co
21c0: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 nd. (
21d0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 70 61 74 68 (not (null? path
21e0: 2d 6f 62 6a 29 29 0a 20 20 20 20 20 20 20 20 20 -obj)).
21f0: 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 (if (equa
2200: 6c 3f 20 63 6f 64 65 20 28 63 61 72 20 70 61 74 l? code (car pat
2210: 68 2d 6f 62 6a 29 29 0a 20 20 20 20 20 20 20 20 h-obj)).
2220: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
2230: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2240: 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c (if (equal
2250: 3f 20 65 78 65 2d 6e 61 6d 65 20 28 63 61 64 72 ? exe-name (cadr
2260: 20 70 61 74 68 2d 6f 62 6a 29 29 0a 20 20 20 20 path-obj)).
2270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2280: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
2290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22a0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
22b0: 28 65 78 65 2d 65 78 69 73 74 20 65 78 65 2d 6e (exe-exist exe-n
22c0: 61 6d 65 20 20 61 63 63 65 73 73 2d 74 79 70 65 ame access-type
22d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
22e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22f0: 20 20 20 20 28 63 6f 70 79 2d 65 78 65 20 61 63 (copy-exe ac
2300: 63 65 73 73 2d 74 79 70 65 20 65 78 65 2d 6e 61 cess-type exe-na
2310: 6d 65 20 67 72 6f 75 70 29 0a 20 20 20 20 20 20 me group).
2320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2330: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
2340: 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
2350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2360: 20 20 20 20 20 28 70 72 69 6e 74 20 22 41 72 65 (print "Are
2370: 61 20 61 6c 72 65 61 64 79 20 6f 70 65 6e 21 21 a already open!!
2380: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23a0: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 (exit 1))))
23b0: 20 20 20 0a 09 09 09 28 62 65 67 69 6e 0a 20 20 ....(begin.
23c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23d0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
23e0: 74 20 28 65 78 65 2d 65 78 69 73 74 20 65 78 65 t (exe-exist exe
23f0: 2d 6e 61 6d 65 20 20 61 63 63 65 73 73 2d 74 79 -name access-ty
2400: 70 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 pe)).
2410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2420: 20 20 20 20 20 20 28 63 6f 70 79 2d 65 78 65 20 (copy-exe
2430: 61 63 63 65 73 73 2d 74 79 70 65 20 65 78 65 2d access-type exe-
2440: 6e 61 6d 65 20 67 72 6f 75 70 29 29 0a 20 20 20 name group)).
2450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2460: 20 20 20 20 20 20 20 20 3b 3b 20 75 70 64 61 74 ;; updat
2470: 65 20 65 78 65 2d 6e 61 6d 65 20 20 69 6e 20 64 e exe-name in d
2480: 62 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 b .
2490: 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f (sautho
24a0: 72 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c 61 rize:db-do (la
24b0: 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 mbda (db).
24c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24d0: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
24e0: 62 2d 71 72 79 20 64 62 20 28 63 6f 6e 63 20 22 b-qry db (conc "
24f0: 75 70 64 61 74 65 20 61 72 65 61 73 20 73 65 74 update areas set
2500: 20 65 78 65 5f 6e 61 6d 65 20 3d 20 27 22 20 65 exe_name = '" e
2510: 78 65 2d 6e 61 6d 65 20 22 27 20 77 68 65 72 65 xe-name "' where
2520: 20 69 64 20 3d 20 22 20 28 63 61 64 64 72 20 70 id = " (caddr p
2530: 61 74 68 2d 6f 62 6a 29 29 29 29 29 0a 20 20 20 ath-obj))))).
2540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2550: 20 20 20 20 20 29 29 29 0a 20 20 20 20 20 20 20 ))).
2560: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
2570: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
2580: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
2590: 20 22 50 61 74 68 20 22 20 70 61 74 68 20 22 20 "Path " path "
25a0: 69 73 20 72 65 67 69 73 74 65 72 65 64 20 77 69 is registered wi
25b0: 74 68 20 2d 2d 63 6f 64 65 20 22 20 28 63 61 72 th --code " (car
25c0: 20 70 61 74 68 2d 6f 62 6a 29 20 22 2e 20 54 6f path-obj) ". To
25d0: 20 6f 70 65 6e 20 74 68 69 73 20 61 72 65 61 20 open this area
25e0: 70 6c 65 61 73 65 20 65 78 65 63 75 74 65 20 66 please execute f
25f0: 6f 6c 6c 6f 77 69 6e 67 20 63 6d 64 3a 20 5c 6e ollowing cmd: \n
2600: 20 20 73 61 75 74 68 6f 72 69 7a 65 20 6f 70 65 sauthorize ope
2610: 6e 20 22 20 70 61 74 68 20 22 20 2d 2d 67 72 6f n " path " --gro
2620: 75 70 20 22 20 67 72 6f 75 70 20 22 20 2d 2d 63 up " group " --c
2630: 6f 64 65 20 22 20 28 63 61 72 20 70 61 74 68 2d ode " (car path-
2640: 6f 62 6a 29 20 22 20 2d 2d 22 20 61 63 63 65 73 obj) " --" acces
2650: 73 2d 74 79 70 65 20 29 0a 20 20 20 20 20 20 20 s-type ).
2660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2670: 28 65 78 69 74 20 31 29 29 29 29 0a 20 20 20 20 (exit 1)))).
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2690: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
26a0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 63 6f 64 65 (not (null? code
26b0: 2d 6f 62 6a 29 29 0a 20 20 20 20 20 20 20 20 20 -obj)).
26c0: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
26d0: 20 22 43 6f 64 65 20 22 20 63 6f 64 65 20 22 20 "Code " code "
26e0: 69 73 20 75 73 65 64 20 66 6f 72 20 64 69 66 66 is used for diff
26f0: 72 65 6e 74 20 70 61 74 68 2e 20 50 6c 65 61 73 rent path. Pleas
2700: 65 20 74 72 79 20 64 69 66 66 72 65 6e 74 20 76 e try diffrent v
2710: 61 6c 75 65 20 6f 66 20 2d 2d 63 6f 64 65 22 20 alue of --code"
2720: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
2730: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a (exit 1)).
2740: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
2750: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
2760: 20 3b 20 28 70 72 69 6e 74 20 28 65 78 65 2d 65 ; (print (exe-e
2770: 78 69 73 74 20 65 78 65 2d 6e 61 6d 65 20 20 61 xist exe-name a
2780: 63 63 65 73 73 2d 74 79 70 65 29 29 0a 20 20 20 ccess-type)).
2790: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
27a0: 20 28 6e 6f 74 20 28 65 78 65 2d 65 78 69 73 74 (not (exe-exist
27b0: 20 65 78 65 2d 6e 61 6d 65 20 20 61 63 63 65 73 exe-name acces
27c0: 73 2d 74 79 70 65 29 29 0a 20 20 20 20 20 20 20 s-type)).
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 20 28 63 6f 70 79 2d 65 78 65 20 61 63 63 65 73 (copy-exe acces
27f0: 73 2d 74 79 70 65 20 65 78 65 2d 6e 61 6d 65 20 s-type exe-name
2800: 67 72 6f 75 70 29 29 0a 20 20 20 20 20 20 20 20 group)).
2810: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
2820: 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c 61 6d ize:db-do (lam
2830: 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 bda (db).
2840: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 63 (print c
2850: 6f 6e 63 20 22 69 6e 73 65 72 74 20 69 6e 74 6f onc "insert into
2860: 20 61 72 65 61 73 20 28 63 6f 64 65 2c 20 62 61 areas (code, ba
2870: 73 65 70 61 74 68 2c 20 65 78 65 5f 6e 61 6d 65 sepath, exe_name
2880: 2c 20 72 65 71 75 69 72 65 64 5f 67 72 70 73 29 , required_grps)
2890: 20 76 61 6c 75 65 73 20 28 27 22 20 63 6f 64 65 values ('" code
28a0: 20 22 27 2c 20 27 22 20 70 61 74 68 20 22 27 2c "', '" path "',
28b0: 20 27 22 20 65 78 65 2d 6e 61 6d 65 20 22 27 2c '" exe-name "',
28c0: 20 27 22 20 6f 74 68 65 72 2d 67 72 70 73 20 22 '" other-grps "
28d0: 27 29 20 22 29 20 0a 20 20 20 20 20 20 20 20 20 ') ") .
28e0: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
28f0: 64 62 2d 71 72 79 20 64 62 20 28 63 6f 6e 63 20 db-qry db (conc
2900: 22 69 6e 73 65 72 74 20 69 6e 74 6f 20 61 72 65 "insert into are
2910: 61 73 20 28 63 6f 64 65 2c 20 62 61 73 65 70 61 as (code, basepa
2920: 74 68 2c 20 65 78 65 5f 6e 61 6d 65 2c 20 72 65 th, exe_name, re
2930: 71 75 69 72 65 64 5f 67 72 70 73 29 20 76 61 6c quired_grps) val
2940: 75 65 73 20 28 27 22 20 63 6f 64 65 20 22 27 2c ues ('" code "',
2950: 20 27 22 20 70 61 74 68 20 22 27 2c 20 27 22 20 '" path "', '"
2960: 65 78 65 2d 6e 61 6d 65 20 22 27 2c 20 27 22 20 exe-name "', '"
2970: 6f 74 68 65 72 2d 67 72 70 73 20 22 27 29 20 22 other-grps "') "
2980: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
2990: 65 20 28 75 73 65 72 2d 68 61 73 2d 6f 70 65 6e e (user-has-open
29a0: 2d 70 65 72 6d 20 75 73 65 72 20 70 61 74 68 20 -perm user path
29b0: 61 63 63 65 73 73 29 0a 20 20 28 6c 65 74 2a 20 access). (let*
29c0: 28 28 68 61 73 2d 61 63 63 65 73 73 20 23 66 29 ((has-access #f)
29d0: 0a 20 20 20 20 20 20 20 20 20 28 65 69 64 20 28 . (eid (
29e0: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
29f0: 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 )). (cond.
2a00: 20 20 28 28 69 73 2d 61 64 6d 69 6e 20 20 75 73 ((is-admin us
2a10: 65 72 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 er). (set!
2a20: 20 68 61 73 2d 61 63 63 65 73 73 20 23 74 20 29 has-access #t )
2a30: 29 0a 20 20 20 20 20 28 28 61 6e 64 20 28 69 73 ). ((and (is
2a40: 2d 72 65 61 64 2d 61 64 6d 69 6e 20 20 75 73 65 -read-admin use
2a50: 72 29 20 28 65 71 75 61 6c 3f 20 61 63 63 65 73 r) (equal? acces
2a60: 73 20 22 72 65 74 72 69 65 76 65 22 29 29 0a 20 s "retrieve")).
2a70: 20 20 20 20 20 20 28 73 65 74 21 20 68 61 73 2d (set! has-
2a80: 61 63 63 65 73 73 20 23 74 20 29 29 0a 20 20 20 access #t )).
2a90: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
2aa0: 28 70 72 69 6e 74 20 22 55 73 65 72 20 22 20 75 (print "User " u
2ab0: 73 65 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 68 ser " does not h
2ac0: 61 76 65 20 70 65 72 6d 69 73 73 69 6f 6e 20 74 ave permission t
2ad0: 6f 20 6f 70 65 6e 20 61 72 65 61 73 22 29 29 29 o open areas")))
2ae0: 0a 20 20 20 20 20 20 20 20 68 61 73 2d 61 63 63 . has-acc
2af0: 65 73 73 29 29 0a 0a 0a 3b 3b 63 68 65 63 6b 20 ess))...;;check
2b00: 69 66 20 75 73 65 72 20 68 61 73 20 67 72 6f 75 if user has grou
2b10: 70 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 p access.(define
2b20: 20 28 69 73 2d 67 72 6f 75 70 2d 77 61 73 68 65 (is-group-washe
2b30: 64 20 72 65 71 5f 67 72 70 69 64 20 63 75 72 72 d req_grpid curr
2b40: 65 6e 74 2d 67 72 70 2d 6c 69 73 74 29 0a 20 20 ent-grp-list).
2b50: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
2b60: 28 63 61 72 20 63 75 72 72 65 6e 74 2d 67 72 70 (car current-grp
2b70: 2d 6c 69 73 74 29 29 0a 09 09 20 28 74 61 6c 20 -list))... (tal
2b80: 28 63 64 72 20 63 75 72 72 65 6e 74 2d 67 72 70 (cdr current-grp
2b90: 2d 6c 69 73 74 29 29 29 0a 20 20 20 20 20 20 20 -list))).
2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
2bb0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
2bc0: 20 20 20 20 20 28 28 65 71 75 61 6c 3f 20 68 65 ((equal? he
2bd0: 64 20 72 65 71 5f 67 72 70 69 64 29 0a 20 20 20 d req_grpid).
2be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bf0: 20 23 74 29 20 20 20 20 0a 20 20 20 20 20 20 20 #t) .
2c00: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 ((nu
2c10: 6c 6c 3f 20 74 61 6c 29 0a 20 20 20 20 20 20 20 ll? tal).
2c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
2c30: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
2c40: 20 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 20 (else ...
2c50: 20 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c .(loop (car tal
2c60: 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 0a )(cdr tal)))))).
2c70: 0a 3b 63 72 65 61 74 65 20 65 78 65 63 75 74 61 .;create executa
2c80: 62 6c 65 73 20 77 69 74 68 20 61 70 70 72 6f 70 bles with approp
2c90: 72 69 61 74 65 20 73 75 69 64 73 0a 28 64 65 66 riate suids.(def
2ca0: 69 6e 65 20 28 73 61 75 74 68 6f 72 69 7a 65 3a ine (sauthorize:
2cb0: 6f 70 65 6e 20 75 73 65 72 20 70 61 74 68 20 67 open user path g
2cc0: 72 6f 75 70 20 63 6f 64 65 20 61 63 63 65 73 73 roup code access
2cd0: 2d 74 79 70 65 20 6f 74 68 65 72 2d 67 72 6f 75 -type other-grou
2ce0: 70 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 67 ps). (let* ((g
2cf0: 70 69 64 20 28 67 72 6f 75 70 2d 69 6e 66 6f 72 pid (group-infor
2d00: 6d 61 74 69 6f 6e 20 67 72 6f 75 70 29 29 0a 20 mation group)).
2d10: 20 20 20 20 20 20 20 20 28 72 65 71 5f 67 72 70 (req_grp
2d20: 69 64 20 28 69 66 20 28 65 71 75 61 6c 3f 20 67 id (if (equal? g
2d30: 72 6f 75 70 20 22 6e 6f 6e 65 22 29 0a 20 20 20 roup "none").
2d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d50: 20 20 20 67 72 6f 75 70 20 0a 20 20 20 20 20 20 group .
2d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d70: 28 69 66 20 28 65 71 75 61 6c 3f 20 67 70 69 64 (if (equal? gpid
2d80: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2da0: 23 66 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 #f .
2db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2dc0: 61 64 64 72 20 67 70 69 64 29 29 29 29 0a 20 20 addr gpid)))).
2dd0: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
2de0: 67 72 70 2d 6c 69 73 74 20 28 67 65 74 2d 67 72 grp-list (get-gr
2df0: 6f 75 70 73 29 29 0a 20 20 20 20 20 20 20 20 20 oups)).
2e00: 28 76 61 6c 69 64 2d 67 72 70 20 28 69 66 20 28 (valid-grp (if (
2e10: 65 71 75 61 6c 3f 20 67 72 6f 75 70 20 22 6e 6f equal? group "no
2e20: 6e 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ne").
2e30: 20 20 20 20 20 20 20 20 20 20 67 72 6f 75 70 0a group.
2e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e50: 20 20 20 20 28 69 73 2d 67 72 6f 75 70 2d 77 61 (is-group-wa
2e60: 73 68 65 64 20 72 65 71 5f 67 72 70 69 64 20 63 shed req_grpid c
2e70: 75 72 72 65 6e 74 2d 67 72 70 2d 6c 69 73 74 29 urrent-grp-list)
2e80: 29 29 29 0a 20 20 20 28 69 66 20 28 61 6e 64 20 ))). (if (and
2e90: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 67 72 6f (not (equal? gro
2ea0: 75 70 20 22 6e 6f 6e 65 22 29 29 20 28 65 71 75 up "none")) (equ
2eb0: 61 6c 3f 20 76 61 6c 69 64 2d 67 72 70 20 23 66 al? valid-grp #f
2ec0: 20 29 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 )). (begi
2ed0: 6e 0a 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 n. (print
2ee0: 22 47 72 6f 75 70 20 22 20 67 72 6f 75 70 20 22 "Group " group "
2ef0: 20 69 73 20 6e 6f 74 20 77 61 73 68 65 64 20 69 is not washed i
2f00: 6e 20 74 68 65 20 63 75 72 72 65 6e 74 20 78 74 n the current xt
2f10: 65 72 6d 21 21 22 29 20 0a 20 20 20 20 20 20 20 erm!!") .
2f20: 28 65 78 69 74 20 31 29 29 29 29 20 0a 20 20 20 (exit 1)))) .
2f30: 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 (if (not (file-w
2f40: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 70 61 74 rite-access? pat
2f50: 68 29 29 0a 20 20 20 20 20 28 62 65 67 69 6e 0a h)). (begin.
2f60: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 59 (print "Y
2f70: 6f 75 20 63 61 6e 20 6f 70 65 6e 20 61 72 65 61 ou can open area
2f80: 73 20 6f 77 6e 65 64 20 62 79 20 79 6f 75 72 73 s owned by yours
2f90: 65 6c 66 2e 20 59 6f 75 20 64 6f 20 6e 6f 74 20 elf. You do not
2fa0: 68 61 76 65 20 70 65 72 6d 69 73 73 69 6f 6e 73 have permissions
2fb0: 20 74 6f 20 6f 70 65 6e 20 70 61 74 68 2e 22 20 to open path."
2fc0: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 28 65 path). (e
2fd0: 78 69 74 20 31 29 29 29 0a 20 20 20 28 69 66 20 xit 1))). (if
2fe0: 28 75 73 65 72 2d 68 61 73 2d 6f 70 65 6e 2d 70 (user-has-open-p
2ff0: 65 72 6d 20 75 73 65 72 20 70 61 74 68 20 61 63 erm user path ac
3000: 63 65 73 73 2d 74 79 70 65 29 0a 20 20 20 20 20 cess-type).
3010: 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 (begin .
3020: 3b 28 70 72 69 6e 74 20 22 68 65 72 65 22 29 20 ;(print "here")
3030: 20 20 0a 20 20 20 20 20 20 20 28 6f 70 65 6e 2d . (open-
3040: 61 72 65 61 20 67 72 6f 75 70 20 70 61 74 68 20 area group path
3050: 63 6f 64 65 20 61 63 63 65 73 73 2d 74 79 70 65 code access-type
3060: 20 6f 74 68 65 72 2d 67 72 6f 75 70 73 29 0a 20 other-groups).
3070: 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a (sauthoriz
3080: 65 3a 67 72 61 6e 74 20 75 73 65 72 20 75 73 65 e:grant user use
3090: 72 20 63 6f 64 65 20 22 32 30 31 37 2f 31 32 2f r code "2017/12/
30a0: 32 35 22 20 20 22 72 65 61 64 2d 61 64 6d 69 6e 25" "read-admin
30b0: 22 20 22 22 29 20 0a 20 20 20 20 20 20 20 28 73 " "") . (s
30c0: 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 authorize:db-do
30d0: 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 (lambda (db).
30e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 (sau
30f0: 74 68 6f 72 69 7a 65 3a 64 62 2d 71 72 79 20 64 thorize:db-qry d
3100: 62 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 b (conc "INSERT
3110: 49 4e 54 4f 20 61 63 74 69 6f 6e 73 20 28 63 6d INTO actions (cm
3120: 64 2c 75 73 65 72 5f 69 64 2c 61 72 65 61 5f 69 d,user_id,area_i
3130: 64 2c 61 63 74 69 6f 6e 5f 74 79 70 65 20 29 20 d,action_type )
3140: 56 41 4c 55 45 53 20 28 27 73 61 75 74 68 6f 72 VALUES ('sauthor
3150: 69 7a 65 20 6f 70 65 6e 20 22 20 70 61 74 68 20 ize open " path
3160: 22 20 2d 2d 63 6f 64 65 20 22 20 63 6f 64 65 20 " --code " code
3170: 22 20 2d 2d 67 72 6f 75 70 20 22 20 67 72 6f 75 " --group " grou
3180: 70 20 22 20 2d 2d 22 20 61 63 63 65 73 73 2d 74 p " --" access-t
3190: 79 70 65 20 22 27 2c 22 20 28 63 61 72 20 28 67 ype "'," (car (g
31a0: 65 74 2d 75 73 65 72 20 75 73 65 72 29 29 20 22 et-user user)) "
31b0: 2c 22 20 28 63 61 72 20 28 67 65 74 2d 61 72 65 ," (car (get-are
31c0: 61 20 63 6f 64 65 29 29 20 22 2c 20 27 6f 70 65 a code)) ", 'ope
31d0: 6e 27 20 29 22 29 29 29 29 0a 20 20 20 20 20 20 n' )")))).
31e0: 20 20 20 28 70 72 69 6e 74 20 22 41 72 65 61 20 (print "Area
31f0: 68 61 73 20 22 20 70 61 74 68 20 22 20 20 62 65 has " path " be
3200: 65 6e 20 6f 70 65 6e 65 64 20 66 6f 72 20 22 20 en opened for "
3210: 61 63 63 65 73 73 2d 74 79 70 65 20 29 29 29 29 access-type ))))
3220: 0a 0a 28 64 65 66 69 6e 65 20 28 73 61 75 74 68 ..(define (sauth
3230: 6f 72 69 7a 65 3a 75 70 64 61 74 65 20 75 73 65 orize:update use
3240: 72 6e 61 6d 65 20 65 78 65 20 61 72 65 61 20 61 rname exe area a
3250: 63 63 65 73 73 2d 74 79 70 65 29 0a 20 20 28 6c ccess-type). (l
3260: 65 74 2a 20 28 28 70 61 72 74 73 20 28 73 74 72 et* ((parts (str
3270: 69 6e 67 2d 73 70 6c 69 74 20 65 78 65 20 22 5f ing-split exe "_
3280: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 6f 77 ")). (ow
3290: 6e 65 72 20 28 63 61 72 20 70 61 72 74 73 29 29 ner (car parts))
32a0: 0a 20 20 20 20 20 20 20 20 20 28 67 72 6f 75 70 . (group
32b0: 20 28 63 61 64 72 20 70 61 72 74 73 29 29 0a 20 (cadr parts)).
32c0: 20 20 20 20 20 20 20 20 28 67 70 69 64 20 28 67 (gpid (g
32d0: 72 6f 75 70 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e roup-information
32e0: 20 67 72 6f 75 70 29 29 0a 20 20 20 20 20 20 20 group)).
32f0: 20 20 28 72 65 71 5f 67 72 70 69 64 20 28 69 66 (req_grpid (if
3300: 20 28 65 71 75 61 6c 3f 20 67 72 6f 75 70 20 22 (equal? group "
3310: 6e 6f 6e 65 22 29 0a 20 20 20 20 20 20 20 20 20 none").
3320: 20 20 20 20 20 20 20 20 20 20 20 20 20 67 72 6f gro
3330: 75 70 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 up .
3340: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 65 (if (e
3350: 71 75 61 6c 3f 20 67 70 69 64 20 23 66 29 0a 20 qual? gpid #f).
3360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3370: 20 20 20 20 20 20 20 20 20 20 23 66 20 20 20 20 #f
3380: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3390: 20 20 20 20 20 20 20 20 28 63 61 64 64 72 20 67 (caddr g
33a0: 70 69 64 29 29 29 29 0a 20 0a 20 20 20 20 20 20 pid)))). .
33b0: 20 20 20 28 63 75 72 72 65 6e 74 2d 67 72 70 2d (current-grp-
33c0: 6c 69 73 74 20 28 67 65 74 2d 67 72 6f 75 70 73 list (get-groups
33d0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 76 61 6c )). (val
33e0: 69 64 2d 67 72 70 20 28 69 66 20 28 65 71 75 61 id-grp (if (equa
33f0: 6c 3f 20 67 72 6f 75 70 20 22 6e 6f 6e 65 22 29 l? group "none")
3400: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3410: 20 20 20 20 20 20 67 72 6f 75 70 0a 20 20 20 20 group.
3420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3430: 28 69 73 2d 67 72 6f 75 70 2d 77 61 73 68 65 64 (is-group-washed
3440: 20 72 65 71 5f 67 72 70 69 64 20 63 75 72 72 65 req_grpid curre
3450: 6e 74 2d 67 72 70 2d 6c 69 73 74 29 29 29 29 0a nt-grp-list)))).
3460: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
3470: 74 20 28 65 71 75 61 6c 3f 20 75 73 65 72 6e 61 t (equal? userna
3480: 6d 65 20 6f 77 6e 65 72 29 29 0a 20 20 20 20 20 me owner)).
3490: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
34a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
34b0: 6e 74 20 22 59 6f 75 20 63 61 6e 6e 6f 74 20 75 nt "You cannot u
34c0: 70 64 61 74 65 20 22 20 61 72 65 61 20 22 2e 20 pdate " area ".
34d0: 4f 6e 6c 79 20 22 20 6f 77 6e 65 72 20 22 20 63 Only " owner " c
34e0: 61 6e 20 75 70 64 61 74 65 20 74 68 69 73 20 61 an update this a
34f0: 72 65 61 21 21 22 29 20 0a 20 20 20 20 20 20 20 rea!!") .
3500: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
3510: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f )). (co
3520: 70 79 2d 65 78 65 20 61 63 63 65 73 73 2d 74 79 py-exe access-ty
3530: 70 65 20 65 78 65 20 67 72 6f 75 70 29 0a 20 20 pe exe group).
3540: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
3550: 22 72 65 63 6f 72 64 69 6e 67 20 61 63 74 69 6f "recording actio
3560: 6e 2e 2e 22 29 20 20 20 20 0a 20 20 20 20 20 20 n..") .
3570: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
3580: 64 62 2d 64 6f 20 20 20 28 6c 61 6d 62 64 61 20 db-do (lambda
3590: 28 64 62 29 0a 20 20 20 20 20 20 20 20 20 20 20 (db).
35a0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
35b0: 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 71 (sauthorize:db-q
35c0: 72 79 20 64 62 20 28 63 6f 6e 63 20 22 49 4e 53 ry db (conc "INS
35d0: 45 52 54 20 49 4e 54 4f 20 61 63 74 69 6f 6e 73 ERT INTO actions
35e0: 20 28 63 6d 64 2c 75 73 65 72 5f 69 64 2c 61 72 (cmd,user_id,ar
35f0: 65 61 5f 69 64 2c 61 63 74 69 6f 6e 5f 74 79 70 ea_id,action_typ
3600: 65 20 29 20 56 41 4c 55 45 53 20 28 27 73 61 75 e ) VALUES ('sau
3610: 74 68 6f 72 69 7a 65 20 75 70 64 61 74 65 20 22 thorize update "
3620: 20 61 72 65 61 20 22 20 2d 2d 22 20 61 63 63 65 area " --" acce
3630: 73 73 2d 74 79 70 65 20 22 27 2c 22 20 28 63 61 ss-type "'," (ca
3640: 72 20 28 67 65 74 2d 75 73 65 72 20 75 73 65 72 r (get-user user
3650: 6e 61 6d 65 29 29 20 22 2c 22 20 28 63 61 72 20 name)) "," (car
3660: 28 67 65 74 2d 61 72 65 61 20 61 72 65 61 29 29 (get-area area))
3670: 20 22 2c 20 27 75 70 64 61 74 65 27 20 29 22 29 ", 'update' )")
3680: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 72 ))). (pr
3690: 69 6e 74 20 22 41 72 65 61 20 68 61 73 20 22 20 int "Area has "
36a0: 61 72 65 61 20 22 20 20 62 65 65 6e 20 75 70 64 area " been upd
36b0: 61 74 65 21 21 22 20 29 29 29 0a 0a 28 64 65 66 ate!!" )))..(def
36c0: 69 6e 65 20 28 73 61 75 74 68 6f 72 69 7a 65 3a ine (sauthorize:
36d0: 67 72 61 6e 74 20 61 75 73 65 72 20 67 75 73 65 grant auser guse
36e0: 72 20 61 72 65 61 20 65 78 70 2d 64 61 74 65 20 r area exp-date
36f0: 61 63 63 65 73 73 2d 74 79 70 65 20 72 65 73 74 access-type rest
3700: 72 69 63 74 29 0a 20 20 20 20 3b 20 63 68 65 63 rict). ; chec
3710: 6b 20 69 66 20 75 73 65 72 20 65 78 69 73 74 20 k if user exist
3720: 69 6e 20 64 62 0a 20 20 20 20 28 6c 65 74 2a 20 in db. (let*
3730: 28 28 61 72 65 61 2d 6f 62 6a 20 28 67 65 74 2d ((area-obj (get-
3740: 61 72 65 61 20 61 72 65 61 29 29 0a 20 20 20 20 area area)).
3750: 20 20 20 20 20 20 20 28 61 75 73 65 72 2d 6f 62 (auser-ob
3760: 6a 20 28 67 65 74 2d 75 73 65 72 20 61 75 73 65 j (get-user ause
3770: 72 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 r)) .
3780: 28 75 73 65 72 2d 6f 62 6a 20 28 67 65 74 2d 75 (user-obj (get-u
3790: 73 65 72 20 67 75 73 65 72 29 29 29 0a 20 20 20 ser guser))).
37a0: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 .
37b0: 28 69 66 20 28 6e 75 6c 6c 3f 20 75 73 65 72 2d (if (null? user-
37c0: 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 20 20 20 obj).
37d0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
37e0: 20 20 20 3b 3b 20 69 73 20 67 75 73 65 72 20 61 ;; is guser a
37f0: 20 76 61 6c 69 64 20 75 6e 69 78 20 75 73 65 72 valid unix user
3800: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if
3810: 20 28 6e 6f 74 20 28 73 61 75 74 68 6f 72 69 7a (not (sauthoriz
3820: 65 3a 76 61 6c 69 64 2d 75 6e 69 78 2d 75 73 65 e:valid-unix-use
3830: 72 20 67 75 73 65 72 29 29 0a 20 20 20 20 20 20 r guser)).
3840: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 (begin
3850: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3860: 20 20 28 70 72 69 6e 74 20 22 55 73 65 72 20 22 (print "User "
3870: 20 67 75 73 65 72 20 22 20 69 73 20 49 6e 76 61 guser " is Inva
3880: 6c 69 64 20 75 6e 69 78 20 75 73 65 72 21 21 22 lid unix user!!"
3890: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
38a0: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 (exit 1))).
38b0: 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 (sauth
38c0: 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c orize:db-do (l
38d0: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
38e0: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
38f0: 69 7a 65 3a 64 62 2d 71 72 79 20 64 62 20 28 63 ize:db-qry db (c
3900: 6f 6e 63 20 22 69 6e 73 65 72 74 20 69 6e 74 6f onc "insert into
3910: 20 75 73 65 72 73 20 28 75 73 65 72 6e 61 6d 65 users (username
3920: 2c 20 69 73 5f 61 64 6d 69 6e 29 20 76 61 6c 75 , is_admin) valu
3930: 65 73 20 28 27 22 20 67 75 73 65 72 20 22 27 2c es ('" guser "',
3940: 20 27 6e 6f 27 29 20 22 29 29 29 29 0a 20 20 20 'no') ")))).
3950: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
3960: 75 73 65 72 2d 6f 62 6a 20 28 67 65 74 2d 75 73 user-obj (get-us
3970: 65 72 20 67 75 73 65 72 29 29 29 29 0a 20 20 20 er guser)))).
3980: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 65 72 (let* ((per
3990: 6d 2d 6f 62 6a 20 28 67 65 74 2d 70 65 72 6d 20 m-obj (get-perm
39a0: 28 63 61 72 20 75 73 65 72 2d 6f 62 6a 29 20 28 (car user-obj) (
39b0: 63 61 72 20 61 72 65 61 2d 6f 62 6a 29 29 29 29 car area-obj))))
39c0: 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 28 6e . (if(n
39d0: 75 6c 6c 3f 20 70 65 72 6d 2d 6f 62 6a 29 0a 20 ull? perm-obj).
39e0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 (begin
39f0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b . ;
3a00: 3b 20 69 6e 73 65 72 74 20 70 65 72 6d 69 73 73 ; insert permiss
3a10: 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 ions.
3a20: 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d (sauthorize:db-
3a30: 64 6f 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 do (lambda (db
3a40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 ). (s
3a50: 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 71 72 79 authorize:db-qry
3a60: 20 64 62 20 28 63 6f 6e 63 20 22 69 6e 73 65 72 db (conc "inser
3a70: 74 20 69 6e 74 6f 20 70 65 72 6d 69 73 73 69 6f t into permissio
3a80: 6e 73 20 28 61 63 63 65 73 73 5f 74 79 70 65 2c ns (access_type,
3a90: 20 75 73 65 72 5f 69 64 2c 20 61 72 65 61 5f 69 user_id, area_i
3aa0: 64 2c 20 72 65 73 74 72 69 63 74 69 6f 6e 2c 20 d, restriction,
3ab0: 65 78 70 69 72 61 74 69 6f 6e 20 29 20 76 61 6c expiration ) val
3ac0: 75 65 73 20 28 27 22 20 61 63 63 65 73 73 2d 74 ues ('" access-t
3ad0: 79 70 65 20 22 27 2c 20 22 20 28 63 61 72 20 75 ype "', " (car u
3ae0: 73 65 72 2d 6f 62 6a 29 20 22 2c 20 22 20 28 63 ser-obj) ", " (c
3af0: 61 72 20 61 72 65 61 2d 6f 62 6a 29 20 22 2c 20 ar area-obj) ",
3b00: 27 22 20 72 65 73 74 72 69 63 74 20 22 27 2c 20 '" restrict "',
3b10: 27 22 20 65 78 70 2d 64 61 74 65 20 22 27 29 22 '" exp-date "')"
3b20: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))).
3b30: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
3b40: 20 20 20 20 20 3b 75 70 64 61 74 65 20 70 65 72 ;update per
3b50: 6d 69 73 73 69 6f 6e 73 0a 20 20 20 20 20 20 20 missions.
3b60: 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a (sauthoriz
3b70: 65 3a 64 62 2d 64 6f 20 20 20 28 6c 61 6d 62 64 e:db-do (lambd
3b80: 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 20 20 a (db).
3b90: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
3ba0: 64 62 2d 71 72 79 20 64 62 20 28 63 6f 6e 63 20 db-qry db (conc
3bb0: 22 75 70 64 61 74 65 20 70 65 72 6d 69 73 73 69 "update permissi
3bc0: 6f 6e 73 20 73 65 74 20 61 63 63 65 73 73 5f 74 ons set access_t
3bd0: 79 70 65 20 3d 20 27 22 20 61 63 63 65 73 73 2d ype = '" access-
3be0: 74 79 70 65 20 22 27 20 2c 20 72 65 73 74 72 69 type "' , restri
3bf0: 63 74 69 6f 6e 20 3d 20 27 22 20 72 65 73 74 72 ction = '" restr
3c00: 69 63 74 20 22 27 2c 20 65 78 70 69 72 61 74 69 ict "', expirati
3c10: 6f 6e 20 3d 20 20 27 22 20 65 78 70 2d 64 61 74 on = '" exp-dat
3c20: 65 20 22 27 20 77 68 65 72 65 20 75 73 65 72 5f e "' where user_
3c30: 69 64 20 3d 20 22 20 28 63 61 72 20 75 73 65 72 id = " (car user
3c40: 2d 6f 62 6a 29 20 22 20 61 6e 64 20 61 72 65 61 -obj) " and area
3c50: 5f 69 64 20 3d 20 22 20 28 63 61 72 20 61 72 65 _id = " (car are
3c60: 61 2d 6f 62 6a 29 29 29 29 29 29 29 0a 20 20 20 a-obj))))))).
3c70: 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 (sauth
3c80: 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c orize:db-do (l
3c90: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
3ca0: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
3cb0: 69 7a 65 3a 64 62 2d 71 72 79 20 64 62 20 28 63 ize:db-qry db (c
3cc0: 6f 6e 63 20 22 49 4e 53 45 52 54 20 49 4e 54 4f onc "INSERT INTO
3cd0: 20 61 63 74 69 6f 6e 73 20 28 63 6d 64 2c 75 73 actions (cmd,us
3ce0: 65 72 5f 69 64 2c 61 72 65 61 5f 69 64 2c 61 63 er_id,area_id,ac
3cf0: 74 69 6f 6e 5f 74 79 70 65 20 29 20 56 41 4c 55 tion_type ) VALU
3d00: 45 53 20 28 27 73 61 75 74 68 6f 72 69 7a 65 20 ES ('sauthorize
3d10: 67 72 61 6e 74 20 22 20 67 75 73 65 72 20 22 20 grant " guser "
3d20: 2d 2d 61 72 65 61 20 22 20 61 72 65 61 20 22 20 --area " area "
3d30: 2d 2d 65 78 70 69 72 61 74 69 6f 6e 20 22 20 65 --expiration " e
3d40: 78 70 2d 64 61 74 65 20 22 20 2d 2d 22 20 61 63 xp-date " --" ac
3d50: 63 65 73 73 2d 74 79 70 65 20 22 20 2d 2d 72 65 cess-type " --re
3d60: 73 74 72 69 63 74 20 22 20 72 65 73 74 72 69 63 strict " restric
3d70: 74 20 22 27 2c 22 20 28 63 61 72 20 61 75 73 65 t "'," (car ause
3d80: 72 2d 6f 62 6a 29 20 22 2c 22 20 28 63 61 72 20 r-obj) "," (car
3d90: 61 72 65 61 2d 6f 62 6a 29 20 22 2c 20 27 67 72 area-obj) ", 'gr
3da0: 61 6e 74 27 20 29 22 29 29 29 29 20 20 0a 20 20 ant' )")))) .
3db0: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
3dc0: 74 20 22 50 65 72 6d 69 73 73 69 6f 6e 20 68 61 t "Permission ha
3dd0: 73 20 62 65 65 6e 20 73 75 63 65 73 73 66 75 6c s been sucessful
3de0: 6c 79 20 67 72 61 6e 74 65 64 20 74 6f 20 75 73 ly granted to us
3df0: 65 72 20 22 20 67 75 73 65 72 29 29 29 29 0a 0a er " guser))))..
3e00: 28 64 65 66 69 6e 65 20 28 73 61 75 74 68 6f 72 (define (sauthor
3e10: 69 7a 65 3a 70 72 6f 63 65 73 73 2d 61 63 74 69 ize:process-acti
3e20: 6f 6e 20 20 75 73 65 72 6e 61 6d 65 20 61 63 74 on username act
3e30: 69 6f 6e 20 2e 20 61 72 67 73 29 0a 20 20 20 28 ion . args). (
3e40: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
3e50: 6d 62 6f 6c 20 61 63 74 69 6f 6e 29 0a 20 20 20 mbol action).
3e60: 28 28 67 72 61 6e 74 29 0a 20 20 20 20 20 20 28 ((grant). (
3e70: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 if (< (length ar
3e80: 67 73 29 20 36 29 0a 20 20 20 20 20 20 20 20 20 gs) 6).
3e90: 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 28 70 (begin .. (p
3ea0: 72 69 6e 74 20 20 22 45 52 52 4f 52 3a 20 4d 69 rint "ERROR: Mi
3eb0: 73 73 69 6e 67 20 61 72 67 75 6d 65 6e 74 73 3b ssing arguments;
3ec0: 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 " (string-inter
3ed0: 73 70 65 72 73 65 20 61 72 67 73 20 22 2c 20 22 sperse args ", "
3ee0: 29 29 0a 09 20 20 20 20 20 28 65 78 69 74 20 31 )).. (exit 1
3ef0: 29 29 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a ))). (let*
3f00: 20 28 28 72 65 6d 61 72 67 73 20 20 20 20 20 28 ((remargs (
3f10: 61 72 67 73 3a 67 65 74 2d 61 72 67 73 20 61 72 args:get-args ar
3f20: 67 73 20 27 28 22 2d 2d 61 72 65 61 22 20 22 2d gs '("--area" "-
3f30: 2d 65 78 70 69 72 61 74 69 6f 6e 22 20 22 2d 2d -expiration" "--
3f40: 72 65 73 74 72 69 63 74 22 29 20 27 28 29 20 61 restrict") '() a
3f50: 72 67 73 3a 61 72 67 2d 68 61 73 68 20 30 29 29 rgs:arg-hash 0))
3f60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3f70: 67 75 73 65 72 20 20 20 20 20 28 63 61 72 20 61 guser (car a
3f80: 72 67 73 29 29 0a 09 20 20 20 20 20 20 28 72 65 rgs)).. (re
3f90: 73 74 72 69 63 74 20 20 20 20 20 20 20 20 20 28 strict (
3fa0: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
3fb0: 20 22 2d 2d 72 65 73 74 72 69 63 74 22 29 20 22 "--restrict") "
3fc0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
3fd0: 20 20 28 61 72 65 61 20 20 20 20 20 20 20 20 20 (area
3fe0: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
3ff0: 67 20 22 2d 2d 61 72 65 61 22 29 20 22 22 29 29 g "--area") ""))
4000: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4010: 20 28 65 78 70 2d 64 61 74 65 20 20 20 20 20 20 (exp-date
4020: 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d (or (args:get-
4030: 61 72 67 20 22 2d 2d 65 78 70 69 72 61 74 69 6f arg "--expiratio
4040: 6e 22 29 20 22 22 29 29 0a 20 20 20 20 20 20 20 n") "")).
4050: 20 20 20 20 20 20 20 28 61 63 63 65 73 73 2d 74 (access-t
4060: 79 70 65 20 28 67 65 74 2d 61 63 63 65 73 73 2d ype (get-access-
4070: 74 79 70 65 20 72 65 6d 61 72 67 73 29 29 29 0a type remargs))).
4080: 09 3b 20 28 70 72 69 6e 74 20 20 22 76 65 72 73 .; (print "vers
4090: 69 6f 6e 20 22 20 67 75 73 65 72 20 22 20 72 65 ion " guser " re
40a0: 73 74 72 69 63 74 20 22 20 72 65 73 74 72 69 63 strict " restric
40b0: 74 20 29 0a 20 20 20 20 20 20 20 20 3b 20 28 70 t ). ; (p
40c0: 72 69 6e 74 20 22 61 72 65 61 20 22 20 61 72 65 rint "area " are
40d0: 61 20 22 20 65 78 70 2d 64 61 74 65 20 22 20 65 a " exp-date " e
40e0: 78 70 2d 64 61 74 65 20 22 20 61 63 63 65 73 73 xp-date " access
40f0: 2d 74 79 70 65 20 22 20 61 63 63 65 73 73 2d 74 -type " access-t
4100: 79 70 65 29 0a 20 20 20 20 20 20 20 20 28 63 6f ype). (co
4110: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 28 28 nd. ((
4120: 65 71 75 61 6c 3f 20 67 75 73 65 72 20 22 22 29 equal? guser "")
4130: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
4140: 70 72 69 6e 74 20 22 55 73 65 72 6e 61 6d 65 20 print "Username
4150: 6e 6f 74 20 66 6f 75 6e 64 21 21 20 54 72 79 20 not found!! Try
4160: 5c 22 73 61 75 74 68 6f 72 69 7a 65 20 68 65 6c \"sauthorize hel
4170: 70 5c 22 20 66 6f 72 20 75 73 65 61 67 65 20 22 p\" for useage "
4180: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4190: 20 28 65 78 69 74 20 31 29 29 20 20 20 0a 20 20 (exit 1)) .
41a0: 20 20 20 20 20 20 20 20 20 28 28 65 71 75 61 6c ((equal
41b0: 3f 20 61 72 65 61 20 22 22 29 0a 20 20 20 20 20 ? area "").
41c0: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
41d0: 22 41 72 65 61 20 6e 6f 74 20 66 6f 75 6e 64 21 "Area not found!
41e0: 21 20 54 72 79 20 5c 22 73 61 75 74 68 6f 72 69 ! Try \"sauthori
41f0: 7a 65 20 68 65 6c 70 5c 22 20 66 6f 72 20 75 73 ze help\" for us
4200: 65 61 67 65 20 22 29 0a 20 20 20 20 20 20 20 20 eage ").
4210: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 20 (exit 1))
4220: 0a 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 . ((eq
4230: 75 61 6c 3f 20 61 63 63 65 73 73 2d 74 79 70 65 ual? access-type
4240: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
4250: 20 20 20 28 70 72 69 6e 74 20 22 41 63 63 65 73 (print "Acces
4260: 73 20 74 79 70 65 20 6e 6f 74 20 66 6f 75 6e 64 s type not found
4270: 21 21 20 54 72 79 20 5c 22 73 61 75 74 68 6f 72 !! Try \"sauthor
4280: 69 7a 65 20 68 65 6c 70 5c 22 20 66 6f 72 20 75 ize help\" for u
4290: 73 65 61 67 65 20 22 29 0a 20 20 20 20 20 20 20 seage ").
42a0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
42b0: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 28 ) . ((
42c0: 65 71 75 61 6c 3f 20 65 78 70 2d 64 61 74 65 20 equal? exp-date
42d0: 22 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 "").
42e0: 20 20 28 70 72 69 6e 74 20 22 44 61 74 65 20 6f (print "Date o
42f0: 66 20 65 78 70 69 72 61 74 69 6f 6e 20 6e 6f 74 f expiration not
4300: 20 66 6f 75 6e 64 21 21 20 54 72 79 20 5c 22 73 found!! Try \"s
4310: 61 75 74 68 6f 72 69 7a 65 20 68 65 6c 70 5c 22 authorize help\"
4320: 20 66 6f 72 20 75 73 65 61 67 65 20 22 29 0a 20 for useage ").
4330: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 (ex
4340: 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 it 1))).
4350: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 72 65 (if (not (are
4360: 61 2d 65 78 69 73 74 73 20 61 72 65 61 29 29 0a a-exists area)).
4370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
4380: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
4390: 20 20 20 28 70 72 69 6e 74 20 22 41 72 65 61 20 (print "Area
43a0: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 69 74 21 does not exisit!
43b0: 21 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 !").
43c0: 20 20 28 65 78 69 74 20 31 29 29 29 20 20 20 0a (exit 1))) .
43d0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
43e0: 63 61 6e 2d 67 72 61 6e 74 2d 70 65 72 6d 20 75 can-grant-perm u
43f0: 73 65 72 6e 61 6d 65 20 61 63 63 65 73 73 2d 74 sername access-t
4400: 79 70 65 20 61 72 65 61 29 0a 09 20 20 20 28 62 ype area).. (b
4410: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
4420: 20 20 28 70 72 69 6e 74 20 22 63 61 6c 6c 69 6e (print "callin
4430: 67 20 73 61 75 74 68 6f 72 69 7a 65 3a 67 72 61 g sauthorize:gra
4440: 6e 74 20 22 29 20 0a 20 20 20 20 20 20 20 20 20 nt ") .
4450: 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 (sauthorize
4460: 3a 67 72 61 6e 74 20 75 73 65 72 6e 61 6d 65 20 :grant username
4470: 67 75 73 65 72 20 61 72 65 61 20 65 78 70 2d 64 guser area exp-d
4480: 61 74 65 20 61 63 63 65 73 73 2d 74 79 70 65 20 ate access-type
4490: 72 65 73 74 72 69 63 74 29 29 20 20 20 0a 20 20 restrict)) .
44a0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
44b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
44c0: 72 69 6e 74 20 22 55 73 65 72 20 22 20 75 73 65 rint "User " use
44d0: 72 6e 61 6d 65 20 22 20 64 6f 65 73 20 6e 6f 74 rname " does not
44e0: 20 68 61 76 65 20 70 65 72 6d 69 73 73 69 6f 6e have permission
44f0: 20 74 6f 20 67 72 61 6e 74 20 70 65 72 6d 69 73 to grant permis
4500: 73 69 6f 6e 73 20 74 6f 20 61 72 65 61 20 22 20 sions to area "
4510: 61 72 65 61 20 22 21 21 22 29 0a 20 20 20 20 20 area "!!").
4520: 20 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 (exit 1
4530: 29 29 29 29 29 0a 20 20 20 20 20 20 20 28 28 6c ))))). ((l
4540: 69 73 74 2d 61 72 65 61 2d 75 73 65 72 29 0a 20 ist-area-user).
4550: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
4560: 74 20 28 65 71 75 61 6c 3f 20 28 6c 65 6e 67 74 t (equal? (lengt
4570: 68 20 61 72 67 73 29 20 31 29 29 0a 20 20 20 20 h args) 1)).
4580: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
4590: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
45a0: 70 72 69 6e 74 20 22 4d 69 73 73 69 6e 67 20 61 print "Missing a
45b0: 72 67 75 6d 65 6e 74 20 61 72 65 61 20 63 6f 64 rgument area cod
45c0: 65 20 74 6f 20 6c 69 73 74 2d 61 72 65 61 2d 75 e to list-area-u
45d0: 73 65 72 20 22 29 20 0a 20 20 20 20 20 20 20 20 ser ") .
45e0: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
45f0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 . (let
4600: 2a 20 28 28 61 72 65 61 20 28 63 61 72 20 61 72 * ((area (car ar
4610: 67 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 gs))).
4620: 20 28 69 66 20 28 6e 6f 74 20 28 61 72 65 61 2d (if (not (area-
4630: 65 78 69 73 74 73 20 61 72 65 61 29 29 0a 20 20 exists area)).
4640: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
4650: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
4660: 20 28 70 72 69 6e 74 20 22 41 72 65 61 20 64 6f (print "Area do
4670: 65 73 20 6e 6f 74 20 65 78 69 73 69 74 21 21 22 es not exisit!!"
4680: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4690: 28 65 78 69 74 20 31 29 29 29 20 0a 20 20 20 20 (exit 1))) .
46a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46b0: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
46c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 (sa
46d0: 75 74 68 6f 72 69 7a 65 3a 6c 69 73 74 2d 61 72 uthorize:list-ar
46e0: 65 61 75 73 65 72 73 20 20 61 72 65 61 20 29 0a eausers area ).
46f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
4700: 0a 20 20 20 20 20 20 28 28 72 65 61 64 2d 73 68 . ((read-sh
4710: 65 6c 6c 29 0a 20 20 20 20 20 20 20 20 20 20 28 ell). (
4720: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
4730: 28 6c 65 6e 67 74 68 20 61 72 67 73 29 20 31 29 (length args) 1)
4740: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4750: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
4760: 20 20 20 20 20 28 70 72 69 6e 74 20 22 4d 69 73 (print "Mis
4770: 73 69 6e 67 20 61 72 67 75 6d 65 6e 74 20 61 72 sing argument ar
4780: 65 61 20 63 6f 64 65 20 74 6f 20 72 65 61 64 2d ea code to read-
4790: 73 68 65 6c 6c 20 22 29 20 0a 20 20 20 20 20 20 shell ") .
47a0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
47b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c )). (l
47c0: 65 74 2a 20 28 28 61 72 65 61 20 28 63 61 72 20 et* ((area (car
47d0: 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 args)).
47e0: 20 20 20 20 20 20 20 20 20 28 63 6f 64 65 2d 6f (code-o
47f0: 62 6a 20 28 67 65 74 2d 6f 62 6a 2d 62 79 2d 63 bj (get-obj-by-c
4800: 6f 64 65 20 61 72 65 61 29 29 29 0a 20 20 20 20 ode area))).
4810: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
4820: 6e 75 6c 6c 3f 20 63 6f 64 65 2d 6f 62 6a 29 0a null? code-obj).
4830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4840: 20 20 20 28 6e 6f 74 20 28 65 78 65 2d 65 78 69 (not (exe-exi
4850: 73 74 20 28 63 61 64 72 20 63 6f 64 65 2d 6f 62 st (cadr code-ob
4860: 6a 29 20 20 22 72 65 74 72 69 65 76 65 22 29 29 j) "retrieve"))
4870: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4880: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
4890: 20 20 20 20 20 28 70 72 69 6e 74 20 22 41 72 65 (print "Are
48a0: 61 20 22 20 61 72 65 61 20 22 20 69 73 20 6e 6f a " area " is no
48b0: 74 20 6f 70 65 6e 20 66 6f 72 20 72 65 61 64 69 t open for readi
48c0: 6e 67 21 21 22 29 0a 20 20 20 20 20 20 20 20 20 ng!!").
48d0: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 20 (exit 1)))
48e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
48f0: 73 61 75 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 sauthorize:do-as
4900: 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 -calling-user.
4910: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
4920: 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 da ().
4930: 20 20 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 (run-cmd (
4940: 63 6f 6e 63 20 2a 65 78 65 2d 70 61 74 68 2a 20 conc *exe-path*
4950: 22 2f 72 65 74 72 69 65 76 65 2f 22 20 28 63 61 "/retrieve/" (ca
4960: 64 72 20 63 6f 64 65 2d 6f 62 6a 29 20 29 20 28 dr code-obj) ) (
4970: 6c 69 73 74 20 22 73 68 65 6c 6c 22 20 61 72 65 list "shell" are
4980: 61 20 29 29 29 29 29 29 0a 20 20 20 20 20 20 28 a )))))). (
4990: 28 77 72 69 74 65 2d 73 68 65 6c 6c 29 0a 20 20 (write-shell).
49a0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
49b0: 20 28 65 71 75 61 6c 3f 20 28 6c 65 6e 67 74 68 (equal? (length
49c0: 20 61 72 67 73 29 20 31 29 29 0a 20 20 20 20 20 args) 1)).
49d0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
49e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
49f0: 72 69 6e 74 20 22 4d 69 73 73 69 6e 67 20 61 72 rint "Missing ar
4a00: 67 75 6d 65 6e 74 20 61 72 65 61 20 63 6f 64 65 gument area code
4a10: 20 74 6f 20 72 65 61 64 2d 73 68 65 6c 6c 20 22 to read-shell "
4a20: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
4a30: 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 (exit 1))).
4a40: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 (let* ((a
4a50: 72 65 61 20 28 63 61 72 20 61 72 67 73 29 29 0a rea (car args)).
4a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a70: 20 20 28 63 6f 64 65 2d 6f 62 6a 20 28 67 65 74 (code-obj (get
4a80: 2d 6f 62 6a 2d 62 79 2d 63 6f 64 65 20 61 72 65 -obj-by-code are
4a90: 61 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 a))).
4aa0: 28 69 66 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 63 (if (or (null? c
4ab0: 6f 64 65 2d 6f 62 6a 29 0a 20 20 20 20 20 20 20 ode-obj).
4ac0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 (not
4ad0: 20 28 65 78 65 2d 65 78 69 73 74 20 28 63 61 64 (exe-exist (cad
4ae0: 72 20 63 6f 64 65 2d 6f 62 6a 29 20 20 22 70 75 r code-obj) "pu
4af0: 62 6c 69 73 68 22 29 29 29 0a 20 20 20 20 20 20 blish"))).
4b00: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
4b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
4b20: 69 6e 74 20 22 41 72 65 61 20 22 20 61 72 65 61 int "Area " area
4b30: 20 22 20 69 73 20 6e 6f 74 20 6f 70 65 6e 20 66 " is not open f
4b40: 6f 72 20 57 72 69 74 69 6e 67 21 21 22 29 0a 20 or Writing!!").
4b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 (ex
4b60: 69 74 20 31 29 29 29 20 0a 20 20 20 20 20 20 20 it 1))) .
4b70: 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 (sauthori
4b80: 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 ze:do-as-calling
4b90: 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 20 20 -user.
4ba0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
4bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
4bc0: 75 6e 2d 63 6d 64 20 28 63 6f 6e 63 20 2a 65 78 un-cmd (conc *ex
4bd0: 65 2d 70 61 74 68 2a 20 22 2f 70 75 62 6c 69 73 e-path* "/publis
4be0: 68 2f 22 20 28 63 61 64 72 20 63 6f 64 65 2d 6f h/" (cadr code-o
4bf0: 62 6a 29 20 29 20 28 6c 69 73 74 20 22 73 68 65 bj) ) (list "she
4c00: 6c 6c 22 20 61 72 65 61 29 29 29 29 29 29 0a 20 ll" area)))))).
4c10: 20 20 20 20 20 28 28 70 75 62 6c 69 73 68 29 0a ((publish).
4c20: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3c (if (<
4c30: 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 20 32 (length args) 2
4c40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4c50: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
4c60: 20 20 20 20 20 28 70 72 69 6e 74 20 22 4d 69 73 (print "Mis
4c70: 73 69 6e 67 20 61 72 67 75 6d 65 6e 74 20 74 6f sing argument to
4c80: 20 70 75 62 6c 69 73 68 2e 20 5c 6e 20 70 75 62 publish. \n pub
4c90: 6c 69 73 68 20 3c 61 63 74 69 6f 6e 3e 20 3c 61 lish <action> <a
4ca0: 72 65 61 3e 20 5b 6f 70 74 73 5d 20 22 29 20 0a rea> [opts] ") .
4cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
4cc0: 78 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 xit 1))).
4cd0: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
4ce0: 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 (let* ((action
4cf0: 28 63 61 72 20 61 72 67 73 29 29 0a 20 20 20 20 (car args)).
4d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
4d10: 72 65 61 20 28 63 61 64 72 20 61 72 67 73 29 29 rea (cadr args))
4d20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4d30: 20 20 20 28 63 6d 64 2d 61 72 67 73 20 28 63 64 (cmd-args (cd
4d40: 64 72 20 61 72 67 73 29 29 20 0a 20 20 20 20 20 dr args)) .
4d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
4d60: 64 65 2d 6f 62 6a 20 28 67 65 74 2d 6f 62 6a 2d de-obj (get-obj-
4d70: 62 79 2d 63 6f 64 65 20 61 72 65 61 29 29 29 0a by-code area))).
4d80: 20 20 20 20 20 20 20 20 20 20 20 3b 28 70 72 69 ;(pri
4d90: 6e 74 20 22 61 72 65 61 20 22 20 61 72 65 61 29 nt "area " area)
4da0: 0a 20 20 20 20 20 20 20 20 20 20 20 3b 28 70 72 . ;(pr
4db0: 69 6e 74 20 22 63 6f 64 65 3a 20 22 20 63 6f 64 int "code: " cod
4dc0: 65 2d 6f 62 6a 29 20 20 0a 20 20 20 20 20 20 20 e-obj) .
4dd0: 20 20 20 20 3b 28 70 72 69 6e 74 20 28 65 78 65 ;(print (exe
4de0: 2d 65 78 69 73 74 20 28 63 61 64 72 20 63 6f 64 -exist (cadr cod
4df0: 65 2d 6f 62 6a 29 20 20 22 70 75 62 6c 69 73 68 e-obj) "publish
4e00: 22 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ")) .
4e10: 28 69 66 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 63 (if (or (null? c
4e20: 6f 64 65 2d 6f 62 6a 29 0a 20 20 20 20 20 20 20 ode-obj).
4e30: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 (not
4e40: 20 28 65 78 65 2d 65 78 69 73 74 20 28 63 61 64 (exe-exist (cad
4e50: 72 20 63 6f 64 65 2d 6f 62 6a 29 20 20 22 70 75 r code-obj) "pu
4e60: 62 6c 69 73 68 22 29 29 29 0a 20 20 20 20 20 20 blish"))).
4e70: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
4e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
4e90: 69 6e 74 20 22 41 72 65 61 20 22 20 61 72 65 61 int "Area " area
4ea0: 20 22 20 69 73 20 6e 6f 74 20 6f 70 65 6e 20 66 " is not open f
4eb0: 6f 72 20 77 72 69 74 69 6e 67 21 21 22 29 0a 20 or writing!!").
4ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 (ex
4ed0: 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 it 1))).
4ee0: 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 22 68 ;(print "h
4ef0: 65 61 72 22 29 20 0a 20 20 20 20 20 20 20 20 20 ear") .
4f00: 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 (sauthorize
4f10: 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 :do-as-calling-u
4f20: 73 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 ser.
4f30: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
4f40: 20 20 20 20 20 20 20 20 20 20 20 3b 20 28 70 72 ; (pr
4f50: 69 6e 74 20 20 2a 65 78 65 2d 70 61 74 68 2a 20 int *exe-path*
4f60: 22 2f 70 75 62 6c 69 73 68 2f 22 20 28 63 61 64 "/publish/" (cad
4f70: 72 20 63 6f 64 65 2d 6f 62 6a 29 20 61 63 74 69 r code-obj) acti
4f80: 6f 6e 20 61 72 65 61 20 63 6d 64 2d 61 72 67 73 on area cmd-args
4f90: 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ).
4fa0: 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f (run-cmd (co
4fb0: 6e 63 20 2a 65 78 65 2d 70 61 74 68 2a 20 22 2f nc *exe-path* "/
4fc0: 70 75 62 6c 69 73 68 2f 22 20 28 63 61 64 72 20 publish/" (cadr
4fd0: 63 6f 64 65 2d 6f 62 6a 29 20 29 20 28 61 70 70 code-obj) ) (app
4fe0: 65 6e 64 20 28 6c 69 73 74 20 61 63 74 69 6f 6e end (list action
4ff0: 20 61 72 65 61 20 29 20 63 6d 64 2d 61 72 67 73 area ) cmd-args
5000: 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a 20 20 )))))). .
5010: 20 20 20 28 28 72 65 74 72 69 65 76 65 29 0a 20 ((retrieve).
5020: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 (if (<
5030: 28 6c 65 6e 67 74 68 20 61 72 67 73 29 20 32 29 (length args) 2)
5040: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
5050: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
5060: 20 20 20 20 28 70 72 69 6e 74 20 22 4d 69 73 73 (print "Miss
5070: 69 6e 67 20 61 72 67 75 6d 65 6e 74 20 74 6f 20 ing argument to
5080: 70 75 62 6c 69 73 68 2e 20 5c 6e 20 70 75 62 6c publish. \n publ
5090: 69 73 68 20 3c 61 63 74 69 6f 6e 3e 20 3c 61 72 ish <action> <ar
50a0: 65 61 3e 20 5b 6f 70 74 73 5d 20 22 29 20 0a 20 ea> [opts] ") .
50b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 (ex
50c0: 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 it 1))).
50d0: 20 20 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f (let* ((actio
50e0: 6e 20 28 63 61 72 20 61 72 67 73 29 29 0a 20 20 n (car args)).
50f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5100: 28 61 72 65 61 20 28 63 61 64 72 20 61 72 67 73 (area (cadr args
5110: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5120: 20 20 20 20 20 28 63 6d 64 2d 61 72 67 73 20 28 (cmd-args (
5130: 63 64 64 72 20 61 72 67 73 29 29 20 0a 20 20 20 cddr args)) .
5140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5150: 63 6f 64 65 2d 6f 62 6a 20 28 67 65 74 2d 6f 62 code-obj (get-ob
5160: 6a 2d 62 79 2d 63 6f 64 65 20 61 72 65 61 29 29 j-by-code area))
5170: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 66 ). (if
5180: 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 63 6f 64 65 (or (null? code
5190: 2d 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 20 20 -obj).
51a0: 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 65 (not (e
51b0: 78 65 2d 65 78 69 73 74 20 28 63 61 64 72 20 63 xe-exist (cadr c
51c0: 6f 64 65 2d 6f 62 6a 29 20 20 22 72 65 74 72 69 ode-obj) "retri
51d0: 65 76 65 22 29 29 29 0a 20 20 20 20 20 20 20 20 eve"))).
51e0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
51f0: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
5200: 74 20 22 41 72 65 61 20 22 20 61 72 65 61 20 22 t "Area " area "
5210: 20 69 73 20 6e 6f 74 20 6f 70 65 6e 20 66 6f 72 is not open for
5220: 20 72 65 61 64 69 6e 67 21 21 22 29 0a 20 20 20 reading!!").
5230: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit
5240: 20 31 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 1))) .
5250: 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 28 63 ;(print (c
5260: 6f 6e 63 20 2a 65 78 65 2d 70 61 74 68 2a 20 22 onc *exe-path* "
5270: 2f 72 65 74 72 69 65 76 65 2f 22 20 28 63 61 64 /retrieve/" (cad
5280: 72 20 63 6f 64 65 2d 6f 62 6a 29 20 22 20 22 20 r code-obj) " "
5290: 61 63 74 69 6f 6e 20 22 20 22 20 61 72 65 61 20 action " " area
52a0: 22 20 22 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e " " (string-join
52b0: 20 63 6d 64 2d 61 72 67 73 29 29 29 0a 20 20 20 cmd-args))).
52c0: 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 (saut
52d0: 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c horize:do-as-cal
52e0: 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 20 20 ling-user.
52f0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
5300: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5310: 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f 6e 63 (run-cmd (conc
5320: 20 2a 65 78 65 2d 70 61 74 68 2a 20 22 2f 72 65 *exe-path* "/re
5330: 74 72 69 65 76 65 2f 22 20 28 63 61 64 72 20 63 trieve/" (cadr c
5340: 6f 64 65 2d 6f 62 6a 29 20 29 20 28 61 70 70 65 ode-obj) ) (appe
5350: 6e 64 20 28 6c 69 73 74 20 61 63 74 69 6f 6e 20 nd (list action
5360: 61 72 65 61 20 29 20 63 6d 64 2d 61 72 67 73 29 area ) cmd-args)
5370: 29 29 29 29 29 0a 0a 20 0a 20 0a 20 20 20 20 20 ))))).. . .
5380: 20 28 28 6f 70 65 6e 29 0a 20 20 20 20 20 20 20 ((open).
5390: 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
53a0: 20 61 72 67 73 29 20 36 29 0a 20 20 20 20 20 20 args) 6).
53b0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
53c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
53d0: 69 6e 74 20 22 73 61 75 74 68 6f 72 69 7a 65 20 int "sauthorize
53e0: 6f 70 65 6e 20 63 6d 64 20 74 61 6b 65 73 20 36 open cmd takes 6
53f0: 20 61 72 67 75 6d 65 6e 74 73 21 21 20 5c 6e 20 arguments!! \n
5400: 55 73 65 61 67 65 3a 20 73 61 75 74 68 6f 72 69 Useage: sauthori
5410: 7a 65 20 6f 70 65 6e 20 3c 70 61 74 68 3e 20 2d ze open <path> -
5420: 2d 67 72 6f 75 70 20 3c 67 72 70 6e 61 6d 65 3e -group <grpname>
5430: 20 2d 2d 63 6f 64 65 20 3c 75 6e 69 71 75 65 20 --code <unique
5440: 73 68 6f 72 74 20 69 64 65 6e 74 69 66 69 65 72 short identifier
5450: 20 66 6f 72 20 61 6e 20 61 72 65 61 3e 20 2d 2d for an area> --
5460: 72 65 74 72 69 65 76 65 7c 2d 2d 70 75 62 6c 69 retrieve|--publi
5470: 73 68 22 29 20 0a 20 20 20 20 20 20 20 20 20 20 sh") .
5480: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 (exit 1))).
5490: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
54a0: 72 65 6d 61 72 67 73 20 20 20 20 20 28 61 72 67 remargs (arg
54b0: 73 3a 67 65 74 2d 61 72 67 73 20 61 72 67 73 20 s:get-args args
54c0: 27 28 22 2d 2d 67 72 6f 75 70 22 20 22 2d 2d 63 '("--group" "--c
54d0: 6f 64 65 22 20 22 2d 2d 61 64 64 69 74 69 6f 6e ode" "--addition
54e0: 61 6c 2d 67 72 70 73 22 29 20 27 28 29 20 61 72 al-grps") '() ar
54f0: 67 73 3a 61 72 67 2d 68 61 73 68 20 30 29 29 0a gs:arg-hash 0)).
5500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
5510: 61 74 68 20 20 20 20 20 28 63 61 72 20 61 72 67 ath (car arg
5520: 73 29 29 0a 09 20 20 20 20 20 20 28 67 72 6f 75 s)).. (grou
5530: 70 20 20 20 20 20 20 20 20 20 28 6f 72 20 28 61 p (or (a
5540: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 2d 67 rgs:get-arg "--g
5550: 72 6f 75 70 22 29 20 22 22 29 29 0a 20 20 20 20 roup") "")).
5560: 20 20 20 20 20 20 20 20 20 20 28 61 72 65 61 20 (area
5570: 20 20 20 20 20 20 20 20 28 6f 72 20 28 61 72 67 (or (arg
5580: 73 3a 67 65 74 2d 61 72 67 20 22 2d 2d 63 6f 64 s:get-arg "--cod
5590: 65 22 29 20 22 22 29 29 0a 20 20 20 20 20 20 20 e") "")).
55a0: 20 20 20 20 20 20 20 28 6f 74 68 65 72 2d 67 72 (other-gr
55b0: 70 73 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 ps (or
55c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
55d0: 2d 61 64 64 69 74 69 6f 6e 61 6c 2d 67 72 70 73 -additional-grps
55e0: 22 29 20 22 22 29 29 20 20 20 20 20 0a 20 20 20 ") "")) .
55f0: 20 20 20 20 20 20 20 20 20 20 20 28 61 63 63 65 (acce
5600: 73 73 2d 74 79 70 65 20 28 67 65 74 2d 61 63 63 ss-type (get-acc
5610: 65 73 73 2d 74 79 70 65 20 72 65 6d 61 72 67 73 ess-type remargs
5620: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
5630: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
5640: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 (cond.
5650: 20 20 20 20 20 20 20 20 20 28 28 65 71 75 61 6c ((equal
5660: 3f 20 70 61 74 68 20 22 22 29 0a 20 20 20 20 20 ? path "").
5670: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
5680: 69 6e 74 20 22 70 61 74 68 20 6e 6f 74 20 66 6f int "path not fo
5690: 75 6e 64 21 21 20 54 72 79 20 5c 22 73 61 75 74 und!! Try \"saut
56a0: 68 6f 72 69 7a 65 20 68 65 6c 70 5c 22 20 66 6f horize help\" fo
56b0: 72 20 75 73 65 61 67 65 20 22 29 0a 20 20 20 20 r useage ").
56c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
56d0: 78 69 74 20 31 29 29 20 20 20 0a 20 20 20 20 20 xit 1)) .
56e0: 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 75 ((equ
56f0: 61 6c 3f 20 61 72 65 61 20 22 22 29 0a 20 20 20 al? area "").
5700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5710: 70 72 69 6e 74 20 22 2d 2d 63 6f 64 65 20 6e 6f print "--code no
5720: 74 20 66 6f 75 6e 64 21 21 20 54 72 79 20 5c 22 t found!! Try \"
5730: 73 61 75 74 68 6f 72 69 7a 65 20 68 65 6c 70 5c sauthorize help\
5740: 22 20 66 6f 72 20 75 73 65 61 67 65 20 22 29 0a " for useage ").
5750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5760: 20 20 28 65 78 69 74 20 31 29 29 20 0a 20 20 20 (exit 1)) .
5770: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 ((e
5780: 71 75 61 6c 3f 20 61 63 63 65 73 73 2d 74 79 70 qual? access-typ
5790: 65 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 e #f).
57a0: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
57b0: 41 63 63 65 73 73 20 74 79 70 65 20 6e 6f 74 20 Access type not
57c0: 66 6f 75 6e 64 21 21 20 54 72 79 20 5c 22 73 61 found!! Try \"sa
57d0: 75 74 68 6f 72 69 7a 65 20 68 65 6c 70 5c 22 20 uthorize help\"
57e0: 66 6f 72 20 75 73 65 61 67 65 20 22 29 0a 20 20 for useage ").
57f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5800: 28 65 78 69 74 20 31 29 29 20 0a 20 20 20 20 20 (exit 1)) .
5810: 20 20 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 ((and
5820: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 61 63 (not (equal? ac
5830: 63 65 73 73 2d 74 79 70 65 20 22 70 75 62 6c 69 cess-type "publi
5840: 73 68 22 29 29 20 0a 20 20 20 20 20 20 20 20 20 sh")) .
5850: 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 65 (not (e
5860: 71 75 61 6c 3f 20 61 63 63 65 73 73 2d 74 79 70 qual? access-typ
5870: 65 20 22 72 65 74 72 69 65 76 65 22 29 29 29 0a e "retrieve"))).
5880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5890: 20 20 28 70 72 69 6e 74 20 22 41 63 63 65 73 73 (print "Access
58a0: 20 74 79 70 65 20 63 61 6e 20 62 65 20 65 69 74 type can be eit
58b0: 65 72 20 2d 2d 72 65 74 72 69 65 76 65 20 6f 72 er --retrieve or
58c0: 20 2d 2d 70 75 62 6c 69 73 68 20 21 21 20 54 72 --publish !! Tr
58d0: 79 20 5c 22 73 61 75 74 68 6f 72 69 7a 65 20 68 y \"sauthorize h
58e0: 65 6c 70 5c 22 20 66 6f 72 20 75 73 65 61 67 65 elp\" for useage
58f0: 20 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ").
5900: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
5910: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5920: 20 3b 20 28 70 72 69 6e 74 20 6f 74 68 65 72 2d ; (print other-
5930: 67 72 70 73 29 20 0a 20 20 20 20 20 20 20 20 20 grps) .
5940: 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 (sauthori
5950: 7a 65 3a 6f 70 65 6e 20 75 73 65 72 6e 61 6d 65 ze:open username
5960: 20 70 61 74 68 20 67 72 6f 75 70 20 61 72 65 61 path group area
5970: 20 61 63 63 65 73 73 2d 74 79 70 65 20 6f 74 68 access-type oth
5980: 65 72 2d 67 72 70 73 29 29 29 0a 20 20 20 20 20 er-grps))).
5990: 20 20 20 20 28 28 75 70 64 61 74 65 29 0a 20 20 ((update).
59a0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3c (if (<
59b0: 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 20 32 (length args) 2
59c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
59d0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
59e0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 73 61 75 (print "sau
59f0: 74 68 6f 72 69 7a 65 20 75 70 64 61 74 65 20 63 thorize update c
5a00: 6d 64 20 74 61 6b 65 73 20 32 20 61 72 67 75 6d md takes 2 argum
5a10: 65 6e 74 73 21 21 20 5c 6e 20 55 73 65 61 67 65 ents!! \n Useage
5a20: 3a 20 73 61 75 74 68 6f 72 69 7a 65 20 75 70 64 : sauthorize upd
5a30: 61 74 65 20 3c 61 72 65 61 2d 63 6f 64 65 3e 20 ate <area-code>
5a40: 2d 2d 72 65 74 72 69 65 76 65 7c 2d 2d 70 75 62 --retrieve|--pub
5a50: 6c 69 73 68 22 29 20 0a 20 20 20 20 20 20 20 20 lish") .
5a60: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
5a70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
5a80: 6c 65 74 2a 20 28 28 61 72 65 61 20 28 63 61 72 let* ((area (car
5a90: 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 args)).
5aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
5ab0: 64 65 2d 6f 62 6a 20 28 67 65 74 2d 6f 62 6a 2d de-obj (get-obj-
5ac0: 62 79 2d 63 6f 64 65 20 61 72 65 61 29 29 0a 20 by-code area)).
5ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ae0: 20 20 20 28 61 63 63 65 73 73 2d 74 79 70 65 20 (access-type
5af0: 28 67 65 74 2d 61 63 63 65 73 73 2d 74 79 70 65 (get-access-type
5b00: 20 28 63 64 72 20 61 72 67 73 29 29 29 29 0a 20 (cdr args)))).
5b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
5b20: 66 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 65 71 f (and (not (eq
5b30: 75 61 6c 3f 20 61 63 63 65 73 73 2d 74 79 70 65 ual? access-type
5b40: 20 22 70 75 62 6c 69 73 68 22 29 29 20 28 6e 6f "publish")) (no
5b50: 74 20 28 65 71 75 61 6c 3f 20 61 63 63 65 73 73 t (equal? access
5b60: 2d 74 79 70 65 20 22 72 65 74 72 69 65 76 65 22 -type "retrieve"
5b70: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
5b80: 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 (begin .
5b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ba0: 28 70 72 69 6e 74 20 22 41 63 63 65 73 73 20 74 (print "Access t
5bb0: 79 70 65 20 63 61 6e 20 62 65 20 2d 2d 72 65 74 ype can be --ret
5bc0: 72 69 65 76 65 7c 2d 2d 70 75 62 6c 69 73 68 20 rieve|--publish
5bd0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
5be0: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a (exit 1))).
5bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
5c00: 66 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 63 6f 64 f (or (null? cod
5c10: 65 2d 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 20 e-obj).
5c20: 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 (not (
5c30: 65 78 65 2d 65 78 69 73 74 20 28 63 61 64 72 20 exe-exist (cadr
5c40: 63 6f 64 65 2d 6f 62 6a 29 20 20 61 63 63 65 73 code-obj) acces
5c50: 73 2d 74 79 70 65 29 29 29 0a 20 20 20 20 20 20 s-type))).
5c60: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
5c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
5c80: 69 6e 74 20 22 41 72 65 61 20 22 20 61 72 65 61 int "Area " area
5c90: 20 22 20 69 73 20 6e 6f 74 20 6f 70 65 6e 20 66 " is not open f
5ca0: 6f 72 20 72 65 61 64 69 6e 67 21 21 22 29 0a 20 or reading!!").
5cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 (ex
5cc0: 69 74 20 31 29 29 29 20 0a 20 20 20 20 20 20 20 it 1))) .
5cd0: 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 (sauthori
5ce0: 7a 65 3a 75 70 64 61 74 65 20 75 73 65 72 6e 61 ze:update userna
5cf0: 6d 65 20 28 63 61 64 72 20 63 6f 64 65 2d 6f 62 me (cadr code-ob
5d00: 6a 29 20 61 72 65 61 20 61 63 63 65 73 73 2d 74 j) area access-t
5d10: 79 70 65 20 29 29 29 20 0a 20 20 20 20 20 20 20 ype ))) .
5d20: 20 20 28 28 61 72 65 61 2d 61 64 6d 69 6e 29 0a ((area-admin).
5d30: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
5d40: 20 28 28 75 73 72 20 28 63 61 72 20 61 72 67 73 ((usr (car args
5d50: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5d60: 20 20 20 20 20 28 75 73 72 2d 6f 62 6a 20 28 67 (usr-obj (g
5d70: 65 74 2d 75 73 65 72 20 75 73 72 29 29 0a 20 20 et-user usr)).
5d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d90: 28 75 73 65 72 2d 69 64 20 28 63 61 72 20 28 67 (user-id (car (g
5da0: 65 74 2d 75 73 65 72 20 75 73 65 72 6e 61 6d 65 et-user username
5db0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
5dc0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5dd0: 20 28 69 66 20 28 69 73 2d 61 64 6d 69 6e 20 20 (if (is-admin
5de0: 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 20 20 20 username).
5df0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
5e00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5e10: 20 20 20 3b 20 28 70 72 69 6e 74 20 75 73 72 2d ; (print usr-
5e20: 6f 62 6a 29 20 0a 20 20 20 20 20 20 20 20 20 20 obj) .
5e30: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
5e40: 6c 3f 20 75 73 72 2d 6f 62 6a 29 0a 20 20 20 20 l? usr-obj).
5e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e60: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
5e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5e80: 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f sauthorize:db-do
5e90: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a (lambda (db).
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 28 ;(
5eb0: 70 72 69 6e 74 20 28 63 6f 6e 63 20 22 49 4e 53 print (conc "INS
5ec0: 45 52 54 20 49 4e 54 4f 20 75 73 65 72 73 20 28 ERT INTO users (
5ed0: 75 73 65 72 6e 61 6d 65 2c 69 73 5f 61 64 6d 69 username,is_admi
5ee0: 6e 29 20 56 41 4c 55 45 53 20 28 20 27 22 20 75 n) VALUES ( '" u
5ef0: 73 72 20 22 27 2c 20 27 72 65 61 64 2d 61 64 6d sr "', 'read-adm
5f00: 69 6e 27 20 29 22 29 29 0a 20 20 20 20 20 20 20 in' )")).
5f10: 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a (sauthoriz
5f20: 65 3a 64 62 2d 71 72 79 20 64 62 20 28 63 6f 6e e:db-qry db (con
5f30: 63 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 75 c "INSERT INTO u
5f40: 73 65 72 73 20 28 75 73 65 72 6e 61 6d 65 2c 69 sers (username,i
5f50: 73 5f 61 64 6d 69 6e 29 20 56 41 4c 55 45 53 20 s_admin) VALUES
5f60: 28 20 27 22 20 75 73 72 20 22 27 2c 20 27 72 65 ( '" usr "', 're
5f70: 61 64 2d 61 64 6d 69 6e 27 20 29 22 29 29 29 29 ad-admin' )"))))
5f80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5f90: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
5fa0: 20 20 20 20 20 20 20 20 3b 20 28 70 72 69 6e 74 ; (print
5fb0: 20 28 63 6f 6e 63 20 22 75 70 64 61 74 65 20 75 (conc "update u
5fc0: 73 65 72 73 20 73 65 74 20 69 73 5f 61 64 6d 69 sers set is_admi
5fd0: 6e 20 3d 20 27 6e 6f 27 20 77 68 65 72 65 20 69 n = 'no' where i
5fe0: 64 20 3d 20 22 20 28 63 61 72 20 75 73 72 2d 6f d = " (car usr-o
5ff0: 62 6a 29 20 29 29 0a 20 20 20 20 20 20 20 20 20 bj) )).
6000: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
6010: 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c 61 6d ize:db-do (lam
6020: 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 bda (db).
6030: 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f (sautho
6040: 72 69 7a 65 3a 64 62 2d 71 72 79 20 64 62 20 28 rize:db-qry db (
6050: 63 6f 6e 63 20 22 75 70 64 61 74 65 20 75 73 65 conc "update use
6060: 72 73 20 73 65 74 20 69 73 5f 61 64 6d 69 6e 20 rs set is_admin
6070: 3d 20 27 72 65 61 64 2d 61 64 6d 69 6e 27 20 77 = 'read-admin' w
6080: 68 65 72 65 20 69 64 20 3d 20 22 20 28 63 61 72 here id = " (car
6090: 20 75 73 72 2d 6f 62 6a 29 29 29 29 29 29 29 0a usr-obj))))))).
60a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60b0: 28 70 72 69 6e 74 20 22 55 73 65 72 20 22 20 75 (print "User " u
60c0: 73 72 20 22 20 69 73 20 75 70 64 61 74 65 64 20 sr " is updated
60d0: 77 69 74 68 20 61 72 65 61 2d 61 64 6d 69 6e 20 with area-admin
60e0: 61 63 63 65 73 73 21 22 29 29 0a 20 20 20 20 20 access!")).
60f0: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
6100: 74 20 22 41 64 6d 69 6e 20 6f 6e 6c 79 20 66 75 t "Admin only fu
6110: 6e 63 74 69 6f 6e 22 29 29 0a 20 20 20 20 20 20 nction")).
6120: 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 (sauth
6130: 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c orize:db-do (l
6140: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
6150: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
6160: 69 7a 65 3a 64 62 2d 71 72 79 20 64 62 20 28 63 ize:db-qry db (c
6170: 6f 6e 63 20 22 49 4e 53 45 52 54 20 49 4e 54 4f onc "INSERT INTO
6180: 20 61 63 74 69 6f 6e 73 20 28 63 6d 64 2c 75 73 actions (cmd,us
6190: 65 72 5f 69 64 2c 61 72 65 61 5f 69 64 2c 61 63 er_id,area_id,ac
61a0: 74 69 6f 6e 5f 74 79 70 65 20 29 20 56 41 4c 55 tion_type ) VALU
61b0: 45 53 20 28 27 61 72 65 61 2d 61 64 6d 69 6e 20 ES ('area-admin
61c0: 22 20 75 73 72 20 22 20 27 2c 20 22 20 75 73 65 " usr " ', " use
61d0: 72 2d 69 64 20 22 2c 30 2c 20 27 61 72 65 61 2d r-id ",0, 'area-
61e0: 61 64 6d 69 6e 20 27 29 22 20 29 29 29 29 29 29 admin ')" ))))))
61f0: 20 0a 20 20 20 20 20 20 20 20 20 20 28 28 6d 6b . ((mk
6200: 2d 61 64 6d 69 6e 29 0a 20 20 20 20 20 20 20 20 -admin).
6210: 20 20 20 28 6c 65 74 2a 20 28 28 75 73 72 20 28 (let* ((usr (
6220: 63 61 72 20 61 72 67 73 29 29 0a 20 20 20 20 20 car args)).
6230: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 75 73 (us
6240: 72 2d 6f 62 6a 20 28 67 65 74 2d 75 73 65 72 20 r-obj (get-user
6250: 75 73 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 usr)).
6260: 20 20 20 20 20 20 20 20 28 75 73 65 72 2d 69 64 (user-id
6270: 20 28 63 61 72 20 28 67 65 74 2d 75 73 65 72 20 (car (get-user
6280: 75 73 65 72 6e 61 6d 65 29 29 29 29 0a 20 20 20 username)))).
6290: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
62a0: 20 28 6e 6f 74 20 28 73 61 75 74 68 6f 72 69 7a (not (sauthoriz
62b0: 65 3a 76 61 6c 69 64 2d 75 6e 69 78 2d 75 73 65 e:valid-unix-use
62c0: 72 20 75 73 72 29 29 0a 20 20 20 20 20 20 20 20 r usr)).
62d0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 20 0a (begin .
62e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
62f0: 28 70 72 69 6e 74 20 22 55 73 65 72 20 22 20 75 (print "User " u
6300: 73 72 20 22 20 69 73 20 49 6e 76 61 6c 69 64 20 sr " is Invalid
6310: 75 6e 69 78 20 75 73 65 72 21 21 22 29 0a 20 20 unix user!!").
6320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6330: 65 78 69 74 20 31 29 29 29 0a 0a 20 20 20 20 20 exit 1)))..
6340: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
6350: 6d 65 6d 62 65 72 20 20 75 73 65 72 6e 61 6d 65 member username
6360: 20 20 2a 73 75 70 65 72 2d 75 73 65 72 73 2a 29 *super-users*)
6370: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6380: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
6390: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
63a0: 75 6c 6c 3f 20 75 73 72 2d 6f 62 6a 29 0a 20 20 ull? usr-obj).
63b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63c0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
63d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63e0: 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d (sauthorize:db-
63f0: 64 6f 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 do (lambda (db
6400: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6410: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 (sa
6420: 75 74 68 6f 72 69 7a 65 3a 64 62 2d 71 72 79 20 uthorize:db-qry
6430: 64 62 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 db (conc "INSERT
6440: 20 49 4e 54 4f 20 75 73 65 72 73 20 28 75 73 65 INTO users (use
6450: 72 6e 61 6d 65 2c 69 73 5f 61 64 6d 69 6e 29 20 rname,is_admin)
6460: 56 41 4c 55 45 53 20 28 20 27 22 20 75 73 72 20 VALUES ( '" usr
6470: 22 27 2c 20 27 79 65 73 27 20 29 22 29 29 29 29 "', 'yes' )"))))
6480: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6490: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
64a0: 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f (sautho
64b0: 72 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c 61 rize:db-do (la
64c0: 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 mbda (db).
64d0: 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 (sauth
64e0: 6f 72 69 7a 65 3a 64 62 2d 71 72 79 20 64 62 20 orize:db-qry db
64f0: 28 63 6f 6e 63 20 22 75 70 64 61 74 65 20 75 73 (conc "update us
6500: 65 72 73 20 73 65 74 20 69 73 5f 61 64 6d 69 6e ers set is_admin
6510: 20 3d 20 27 79 65 73 27 20 77 68 65 72 65 20 69 = 'yes' where i
6520: 64 20 3d 20 22 20 28 63 61 72 20 75 73 72 2d 6f d = " (car usr-o
6530: 62 6a 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 bj))))))).
6540: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
6550: 20 22 55 73 65 72 20 22 20 75 73 72 20 22 20 69 "User " usr " i
6560: 73 20 75 70 64 61 74 65 64 20 77 69 74 68 20 61 s updated with a
6570: 64 6d 69 6e 20 61 63 63 65 73 73 21 22 29 29 0a dmin access!")).
6580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6590: 28 70 72 69 6e 74 20 22 53 75 70 65 72 2d 41 64 (print "Super-Ad
65a0: 6d 69 6e 20 6f 6e 6c 79 20 66 75 6e 63 74 69 6f min only functio
65b0: 6e 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 n")).
65c0: 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 (sauthorize
65d0: 3a 64 62 2d 64 6f 20 20 20 28 6c 61 6d 62 64 61 :db-do (lambda
65e0: 20 28 64 62 29 0a 20 20 20 20 20 20 20 20 20 20 (db).
65f0: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
6600: 62 2d 71 72 79 20 64 62 20 28 63 6f 6e 63 20 22 b-qry db (conc "
6610: 49 4e 53 45 52 54 20 49 4e 54 4f 20 61 63 74 69 INSERT INTO acti
6620: 6f 6e 73 20 28 63 6d 64 2c 75 73 65 72 5f 69 64 ons (cmd,user_id
6630: 2c 61 72 65 61 5f 69 64 2c 61 63 74 69 6f 6e 5f ,area_id,action_
6640: 74 79 70 65 20 29 20 56 41 4c 55 45 53 20 28 27 type ) VALUES ('
6650: 6d 6b 2d 61 64 6d 69 6e 20 22 20 75 73 72 20 22 mk-admin " usr "
6660: 20 27 2c 20 22 20 75 73 65 72 2d 69 64 20 22 2c ', " user-id ",
6670: 30 2c 20 27 6d 6b 2d 61 64 6d 69 6e 20 27 29 22 0, 'mk-admin ')"
6680: 20 29 29 29 29 29 29 20 0a 0a 20 20 20 20 20 20 )))))) ..
6690: 20 20 20 28 28 72 65 67 69 73 74 65 72 2d 6c 6f ((register-lo
66a0: 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 g). (
66b0: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 if (< (length ar
66c0: 67 73 29 20 34 29 0a 20 20 20 20 20 20 20 20 20 gs) 4).
66d0: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 49 (print "I
66e0: 6e 76 61 6c 69 64 20 61 72 67 75 6d 65 6e 74 73 nvalid arguments
66f0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
6700: 20 3b 28 70 72 69 6e 74 20 61 72 67 73 29 0a 20 ;(print args).
6710: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
6720: 2a 20 28 28 63 6d 64 2d 6c 69 6e 65 20 28 63 61 * ((cmd-line (ca
6730: 72 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 r args)).
6740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 75 (u
6750: 73 65 72 2d 69 64 20 28 63 61 64 72 20 61 72 67 ser-id (cadr arg
6760: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
6770: 20 20 20 20 20 20 20 20 20 28 61 72 65 61 2d 69 (area-i
6780: 64 20 28 63 61 64 64 72 20 61 72 67 73 29 29 0a d (caddr args)).
6790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67a0: 20 20 20 20 20 28 75 73 65 72 2d 6f 62 6a 20 28 (user-obj (
67b0: 67 65 74 2d 75 73 65 72 20 75 73 65 72 6e 61 6d get-user usernam
67c0: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
67d0: 20 20 20 20 20 20 20 20 20 20 28 63 6d 64 20 28 (cmd (
67e0: 63 61 64 64 64 72 20 61 72 67 73 29 29 29 0a 20 cadddr args))).
67f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
6800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6810: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 if (and (not (nu
6820: 6c 6c 3f 20 75 73 65 72 2d 6f 62 6a 29 29 20 28 ll? user-obj)) (
6830: 65 71 75 61 6c 3f 20 75 73 65 72 2d 69 64 20 28 equal? user-id (
6840: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 28 63 number->string(c
6850: 61 72 20 75 73 65 72 2d 6f 62 6a 29 29 29 29 0a ar user-obj)))).
6860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6870: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
6880: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
6890: 69 7a 65 3a 64 62 2d 64 6f 20 20 20 28 6c 61 6d ize:db-do (lam
68a0: 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 bda (db).
68b0: 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a (sauthoriz
68c0: 65 3a 64 62 2d 71 72 79 20 64 62 20 28 63 6f 6e e:db-qry db (con
68d0: 63 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 61 c "INSERT INTO a
68e0: 63 74 69 6f 6e 73 20 28 63 6d 64 2c 75 73 65 72 ctions (cmd,user
68f0: 5f 69 64 2c 61 72 65 61 5f 69 64 2c 61 63 74 69 _id,area_id,acti
6900: 6f 6e 5f 74 79 70 65 20 29 20 56 41 4c 55 45 53 on_type ) VALUES
6910: 20 28 27 22 20 63 6d 64 2d 6c 69 6e 65 22 27 2c ('" cmd-line"',
6920: 20 22 20 75 73 65 72 2d 69 64 20 22 2c 22 20 61 " user-id "," a
6930: 72 65 61 2d 69 64 20 22 2c 20 27 22 20 63 6d 64 rea-id ", '" cmd
6940: 20 22 27 29 22 20 29 29 29 29 29 0a 20 20 20 20 "')" ))))).
6950: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
6960: 6e 74 20 22 59 6f 75 20 61 72 20 6e 6f 74 20 61 nt "You ar not a
6970: 75 74 68 6f 72 69 73 65 64 20 74 6f 20 72 75 6e uthorised to run
6980: 20 74 68 69 73 20 63 6d 64 22 29 0a 0a 29 29 29 this cmd")..)))
6990: 20 20 20 20 20 0a 0a 20 20 20 20 20 20 20 0a 20 .. .
69a0: 20 20 20 20 20 28 65 6c 73 65 20 28 70 72 69 6e (else (prin
69b0: 74 20 30 20 22 55 6e 72 65 63 6f 67 6e 69 73 65 t 0 "Unrecognise
69c0: 64 20 63 6f 6d 6d 61 6e 64 20 22 20 61 63 74 69 d command " acti
69d0: 6f 6e 29 29 29 29 0a 20 20 0a 28 64 65 66 69 6e on)))). .(defin
69e0: 65 20 28 6d 61 69 6e 29 0a 20 20 28 6c 65 74 2a e (main). (let*
69f0: 20 28 28 61 72 67 73 20 20 20 20 20 20 28 61 72 ((args (ar
6a00: 67 76 29 29 0a 09 20 28 70 72 6f 67 20 20 20 20 gv)).. (prog
6a10: 20 20 28 63 61 72 20 61 72 67 73 29 29 0a 09 20 (car args))..
6a20: 28 72 65 6d 61 20 20 20 20 20 20 28 63 64 72 20 (rema (cdr
6a30: 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 args)).
6a40: 28 75 73 65 72 6e 61 6d 65 20 20 20 20 20 28 63 (username (c
6a50: 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 urrent-user-name
6a60: 29 29 29 0a 20 20 20 20 3b 3b 20 70 72 65 73 65 ))). ;; prese
6a70: 72 76 65 20 74 68 65 20 65 78 65 20 64 61 74 61 rve the exe data
6a80: 20 69 6e 20 74 68 65 20 63 6f 6e 66 69 67 20 66 in the config f
6a90: 69 6c 65 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ile. (cond.
6aa0: 20 20 20 3b 3b 20 6f 6e 65 2d 77 6f 72 64 20 63 ;; one-word c
6ab0: 6f 6d 6d 61 6e 64 73 0a 20 20 20 20 20 28 28 65 ommands. ((e
6ac0: 71 3f 20 28 6c 65 6e 67 74 68 20 72 65 6d 61 29 q? (length rema)
6ad0: 20 31 29 0a 20 20 20 20 20 20 28 63 61 73 65 20 1). (case
6ae0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
6af0: 28 63 61 72 20 72 65 6d 61 29 29 0a 09 28 28 68 (car rema))..((h
6b00: 65 6c 70 20 2d 68 20 2d 68 65 6c 70 20 2d 2d 68 elp -h -help --h
6b10: 20 2d 2d 68 65 6c 70 29 0a 09 20 28 70 72 69 6e --help).. (prin
6b20: 74 20 73 61 75 74 68 6f 72 69 7a 65 3a 68 65 6c t sauthorize:hel
6b30: 70 29 29 0a 09 28 28 6c 69 73 74 29 0a 20 20 20 p))..((list).
6b40: 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
6b50: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
6b60: 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 db-do (lambda (
6b70: 64 62 29 0a 09 09 09 09 20 20 20 20 20 28 70 72 db)..... (pr
6b80: 69 6e 74 20 22 4d 79 20 41 72 65 61 20 61 63 63 int "My Area acc
6b90: 65 73 73 65 73 3a 20 22 29 0a 09 09 09 09 20 20 esses: ").....
6ba0: 20 20 20 28 71 75 65 72 79 20 28 66 6f 72 2d 65 (query (for-e
6bb0: 61 63 68 2d 72 6f 77 0a 09 09 09 09 09 20 20 20 ach-row......
6bc0: 20 20 28 6c 61 6d 62 64 61 20 28 72 6f 77 29 0a (lambda (row).
6bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6c00: 6c 65 74 2a 20 28 28 65 78 70 2d 64 61 74 65 20 let* ((exp-date
6c10: 28 63 61 72 20 72 6f 77 29 29 29 0a 20 20 20 20 (car row))).
6c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c40: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
6c50: 20 28 69 73 2d 61 63 63 65 73 73 2d 76 61 6c 69 (is-access-vali
6c60: 64 20 20 65 78 70 2d 64 61 74 65 29 20 20 20 20 d exp-date)
6c70: 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 20 20 ......
6c80: 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 28 (apply print (
6c90: 69 6e 74 65 72 73 70 65 72 73 65 20 28 63 64 72 intersperse (cdr
6ca0: 20 72 6f 77 29 20 22 20 7c 20 22 29 29 29 29 29 row) " | ")))))
6cb0: 29 0a 09 09 09 09 09 20 20 20 20 28 73 71 6c 20 )...... (sql
6cc0: 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 db (conc "SELECT
6cd0: 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 65 78 70 permissions.exp
6ce0: 69 72 61 74 69 6f 6e 2c 20 61 72 65 61 73 2e 62 iration, areas.b
6cf0: 61 73 65 70 61 74 68 2c 20 61 72 65 61 73 2e 63 asepath, areas.c
6d00: 6f 64 65 2c 20 70 65 72 6d 69 73 73 69 6f 6e 73 ode, permissions
6d10: 2e 61 63 63 65 73 73 5f 74 79 70 65 20 20 46 52 .access_type FR
6d20: 4f 4d 20 75 73 65 72 73 2c 20 61 72 65 61 73 2c OM users, areas,
6d30: 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 77 68 65 permissions whe
6d40: 72 65 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 75 re permissions.u
6d50: 73 65 72 5f 69 64 20 3d 20 75 73 65 72 73 2e 69 ser_id = users.i
6d60: 64 20 61 6e 64 20 70 65 72 6d 69 73 73 69 6f 6e d and permission
6d70: 73 2e 61 72 65 61 5f 69 64 20 3d 20 61 72 65 61 s.area_id = area
6d80: 73 2e 69 64 20 61 6e 64 20 75 73 65 72 73 2e 75 s.id and users.u
6d90: 73 65 72 6e 61 6d 65 20 3d 20 27 22 20 75 73 65 sername = '" use
6da0: 72 6e 61 6d 65 20 22 27 22 29 29 29 29 29 29 0a rname "'")))))).
6db0: 20 20 20 20 20 20 20 20 20 0a 09 28 28 6c 6f 67 ..((log
6dc0: 29 0a 09 20 28 73 61 75 74 68 6f 72 69 7a 65 3a ).. (sauthorize:
6dd0: 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 db-do (lambda (
6de0: 64 62 29 0a 09 09 09 09 20 20 20 20 20 28 70 72 db)..... (pr
6df0: 69 6e 74 20 22 4c 6f 67 73 20 3a 20 22 29 0a 09 int "Logs : ")..
6e00: 09 09 09 20 20 20 20 20 28 71 75 65 72 79 20 28 ... (query (
6e10: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 09 09 for-each-row....
6e20: 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
6e30: 72 6f 77 29 0a 20 20 20 20 20 20 20 20 20 20 20 row).
6e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e60: 20 20 20 20 20 20 20 20 0a 09 09 09 09 09 20 20 ......
6e70: 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e (apply prin
6e80: 74 20 28 69 6e 74 65 72 73 70 65 72 73 65 20 72 t (intersperse r
6e90: 6f 77 20 22 20 7c 20 22 29 29 29 29 0a 09 09 09 ow " | "))))....
6ea0: 09 09 20 20 20 20 28 73 71 6c 20 64 62 20 22 53 .. (sql db "S
6eb0: 45 4c 45 43 54 20 61 63 74 69 6f 6e 73 2e 63 6d ELECT actions.cm
6ec0: 64 2c 20 75 73 65 72 73 2e 75 73 65 72 6e 61 6d d, users.usernam
6ed0: 65 2c 20 61 63 74 69 6f 6e 73 2e 61 63 74 69 6f e, actions.actio
6ee0: 6e 5f 74 79 70 65 2c 20 61 63 74 69 6f 6e 73 2e n_type, actions.
6ef0: 64 61 74 65 74 69 6d 65 2c 20 61 72 65 61 73 2e datetime, areas.
6f00: 63 6f 64 65 20 20 46 52 4f 4d 20 61 63 74 69 6f code FROM actio
6f10: 6e 73 2c 20 75 73 65 72 73 2c 20 61 72 65 61 73 ns, users, areas
6f20: 20 77 68 65 72 65 20 61 63 74 69 6f 6e 73 2e 75 where actions.u
6f30: 73 65 72 5f 69 64 20 3d 20 75 73 65 72 73 2e 69 ser_id = users.i
6f40: 64 20 61 6e 64 20 61 63 74 69 6f 6e 73 2e 61 72 d and actions.ar
6f50: 65 61 5f 69 64 20 3d 20 61 72 65 61 73 2e 69 64 ea_id = areas.id
6f60: 20 22 29 29 29 29 29 0a 09 28 65 6c 73 65 0a 09 ")))))..(else..
6f70: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
6f80: 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 63 6f 6d Unrecognised com
6f90: 6d 61 6e 64 2e 20 54 72 79 20 5c 22 73 61 75 74 mand. Try \"saut
6fa0: 68 6f 72 69 7a 65 20 68 65 6c 70 5c 22 22 29 29 horize help\""))
6fb0: 29 29 0a 20 20 20 20 20 3b 3b 20 6d 75 6c 74 69 )). ;; multi
6fc0: 2d 77 6f 72 64 20 63 6f 6d 6d 61 6e 64 73 0a 20 -word commands.
6fd0: 20 20 20 20 28 28 6e 75 6c 6c 3f 20 72 65 6d 61 ((null? rema
6fe0: 29 28 70 72 69 6e 74 20 73 61 75 74 68 6f 72 69 )(print sauthori
6ff0: 7a 65 3a 68 65 6c 70 29 29 0a 20 20 20 20 20 28 ze:help)). (
7000: 28 3e 3d 20 28 6c 65 6e 67 74 68 20 72 65 6d 61 (>= (length rema
7010: 29 20 32 29 0a 20 20 20 20 20 20 28 61 70 70 6c ) 2). (appl
7020: 79 20 73 61 75 74 68 6f 72 69 7a 65 3a 70 72 6f y sauthorize:pro
7030: 63 65 73 73 2d 61 63 74 69 6f 6e 20 75 73 65 72 cess-action user
7040: 6e 61 6d 65 20 28 63 61 72 20 72 65 6d 61 29 28 name (car rema)(
7050: 63 64 72 20 72 65 6d 61 29 29 29 0a 20 20 20 20 cdr rema))).
7060: 20 28 65 6c 73 65 20 28 64 65 62 75 67 3a 70 72 (else (debug:pr
7070: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 55 6e int 0 "ERROR: Un
7080: 72 65 63 6f 67 6e 69 73 65 64 20 63 6f 6d 6d 61 recognised comma
7090: 6e 64 2e 20 54 72 79 20 5c 22 73 61 75 74 68 6f nd. Try \"sautho
70a0: 72 69 7a 65 20 68 65 6c 70 5c 22 22 29 29 29 29 rize help\""))))
70b0: 29 0a 0a 28 6d 61 69 6e 29 0a 0a 0a 20 20 20 20 )..(main)...
70c0: 20 20 0a .