Artifact
5771575e2e0e2441426bdc1b554cb3de4c8372af:
0000: 3b 3b 20 20 43 6f 70 79 72 69 67 68 74 20 32 30 ;; Copyright 20
0010: 30 36 2d 32 30 31 37 2c 20 4d 61 74 74 68 65 77 06-2017, 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 0a 0a 3b 3b 20 43 72 65 nses/>....;; Cre
0300: 61 74 65 20 74 68 65 20 73 71 6c 69 74 65 20 64 ate the sqlite d
0310: 62 0a 28 64 65 66 69 6e 65 20 28 73 61 75 74 68 b.(define (sauth
0320: 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 70 72 6f 63 orize:db-do proc
0330: 29 20 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 ) . (if (or
0340: 20 28 6e 6f 74 20 2a 64 62 2d 70 61 74 68 2a 29 (not *db-path*)
0350: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
0360: 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 not (file-exists
0370: 3f 20 2a 64 62 2d 70 61 74 68 2a 29 29 29 20 0a ? *db-path*))) .
0380: 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e .(begin.. (prin
0390: 74 20 30 20 22 5b 64 61 74 61 62 61 73 65 5d 5c t 0 "[database]\
03a0: 6e 6c 6f 63 61 74 69 6f 6e 20 22 20 2a 64 62 2d nlocation " *db-
03b0: 70 61 74 68 2a 20 22 20 5c 6e 5c 6e 20 49 73 20 path* " \n\n Is
03c0: 6d 69 73 73 69 6e 67 20 66 72 6f 6d 20 74 68 65 missing from the
03d0: 20 63 6f 6e 66 69 67 20 66 69 6c 65 21 22 29 0a config file!").
03e0: 09 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 . (exit 1))).
03f0: 20 20 28 69 66 20 28 61 6e 64 20 2a 64 62 2d 70 (if (and *db-p
0400: 61 74 68 2a 0a 09 20 20 20 20 20 28 64 69 72 65 ath*.. (dire
0410: 63 74 6f 72 79 3f 20 2a 64 62 2d 70 61 74 68 2a ctory? *db-path*
0420: 29 0a 09 20 20 20 20 20 28 66 69 6c 65 2d 72 65 ).. (file-re
0430: 61 64 2d 61 63 63 65 73 73 3f 20 2a 64 62 2d 70 ad-access? *db-p
0440: 61 74 68 2a 29 29 0a 09 28 6c 65 74 2a 20 28 28 ath*))..(let* ((
0450: 64 62 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 dbpath (conc
0460: 2a 64 62 2d 70 61 74 68 2a 20 22 2f 73 61 75 74 *db-path* "/saut
0470: 68 6f 72 69 7a 65 2e 64 62 22 29 29 0a 09 20 20 horize.db"))..
0480: 20 20 20 20 20 28 77 72 69 74 65 61 62 6c 65 20 (writeable
0490: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
04a0: 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 20 20 ss? dbpath))..
04b0: 20 20 20 20 20 28 64 62 65 78 69 73 74 73 20 20 (dbexists
04c0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 (file-exists? db
04d0: 70 61 74 68 29 29 29 0a 09 20 20 28 68 61 6e 64 path))).. (hand
04e0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 le-exceptions..
04f0: 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 6e exn.. (begin
0500: 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 32 20 .. (print 2
0510: 22 45 52 52 4f 52 3a 20 70 72 6f 62 6c 65 6d 20 "ERROR: problem
0520: 61 63 63 65 73 73 69 6e 67 20 64 62 20 22 20 64 accessing db " d
0530: 62 70 61 74 68 0a 09 09 09 20 20 28 28 63 6f 6e bpath.... ((con
0540: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
0550: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
0560: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 essage) exn))..
0570: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 (exit 1)).
0580: 20 20 20 20 20 20 20 20 20 20 3b 28 70 72 69 6e ;(prin
0590: 74 20 20 22 63 61 6c 6c 69 6e 67 20 70 72 6f 63 t "calling proc
05a0: 20 22 20 70 72 6f 63 20 22 64 62 20 70 61 74 68 " proc "db path
05b0: 20 22 20 64 62 70 61 74 68 20 29 0a 09 20 20 20 " dbpath )..
05c0: 28 63 61 6c 6c 2d 77 69 74 68 2d 64 61 74 61 62 (call-with-datab
05d0: 61 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ase.
05e0: 64 62 70 61 74 68 0a 09 20 20 20 20 28 6c 61 6d dbpath.. (lam
05f0: 62 64 61 20 28 64 62 29 0a 09 20 20 20 20 20 20 bda (db)..
0600: 20 3b 28 70 72 69 6e 74 20 30 20 22 63 61 6c 6c ;(print 0 "call
0610: 69 6e 67 20 70 72 6f 63 20 22 20 70 72 6f 63 20 ing proc " proc
0620: 22 20 6f 6e 20 64 62 20 22 20 64 62 29 0a 09 20 " on db " db)..
0630: 20 20 20 20 20 28 73 65 74 2d 62 75 73 79 2d 68 (set-busy-h
0640: 61 6e 64 6c 65 72 21 20 64 62 20 28 62 75 73 79 andler! db (busy
0650: 2d 74 69 6d 65 6f 75 74 20 31 30 30 30 30 29 29 -timeout 10000))
0660: 20 3b 3b 20 31 30 20 73 65 63 20 74 69 6d 65 6f ;; 10 sec timeo
0670: 75 74 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e ut.. (if (n
0680: 6f 74 20 64 62 65 78 69 73 74 73 29 28 73 61 75 ot dbexists)(sau
0690: 74 68 6f 72 69 7a 65 3a 69 6e 69 74 69 61 6c 69 thorize:initiali
06a0: 7a 65 2d 64 62 20 64 62 29 29 0a 09 20 20 20 20 ze-db db))..
06b0: 20 20 28 70 72 6f 63 20 64 62 29 29 29 29 29 0a (proc db))))).
06c0: 09 28 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 .(print 0 "ERROR
06d0: 3a 20 69 6e 76 61 6c 69 64 20 70 61 74 68 20 66 : invalid path f
06e0: 6f 72 20 73 74 6f 72 69 6e 67 20 64 61 74 61 62 or storing datab
06f0: 61 73 65 3a 20 22 20 2a 64 62 2d 70 61 74 68 2a ase: " *db-path*
0700: 29 29 29 0a 0a 3b 3b 65 78 65 63 75 74 65 20 61 )))..;;execute a
0710: 20 71 75 65 72 79 0a 28 64 65 66 69 6e 65 20 28 query.(define (
0720: 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 71 72 sauthorize:db-qr
0730: 79 20 64 62 20 71 72 79 29 0a 20 20 3b 28 70 72 y db qry). ;(pr
0740: 69 6e 74 20 71 72 79 29 0a 20 20 28 65 78 65 63 int qry). (exec
0750: 20 28 73 71 6c 20 64 62 20 20 71 72 79 29 29 29 (sql db qry)))
0760: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 61 75 74 ...(define (saut
0770: 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c horize:do-as-cal
0780: 6c 69 6e 67 2d 75 73 65 72 20 70 72 6f 63 29 0a ling-user proc).
0790: 20 20 28 6c 65 74 20 28 28 65 69 64 20 28 63 75 (let ((eid (cu
07a0: 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d rrent-effective-
07b0: 75 73 65 72 2d 69 64 29 29 0a 20 20 20 20 20 20 user-id)).
07c0: 20 20 28 63 69 64 20 28 63 75 72 72 65 6e 74 2d (cid (current-
07d0: 75 73 65 72 2d 69 64 29 29 29 0a 20 20 20 20 28 user-id))). (
07e0: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 65 69 64 if (not (eq? eid
07f0: 20 63 69 64 29 29 20 3b 3b 20 72 75 6e 6e 69 6e cid)) ;; runnin
0800: 67 20 73 75 69 64 0a 20 20 20 20 20 20 20 20 20 g suid.
0810: 20 20 20 28 73 65 74 21 20 28 63 75 72 72 65 6e (set! (curren
0820: 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 65 72 t-effective-user
0830: 2d 69 64 29 20 63 69 64 29 29 0a 20 20 20 20 20 -id) cid)).
0840: 3b 28 70 72 69 6e 74 20 30 20 22 63 69 64 20 22 ;(print 0 "cid "
0850: 20 63 69 64 20 22 20 65 69 64 3a 22 20 65 69 64 cid " eid:" eid
0860: 29 0a 20 20 20 20 28 70 72 6f 63 29 0a 20 20 20 ). (proc).
0870: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 65 (if (not (eq? e
0880: 69 64 20 63 69 64 29 29 0a 20 20 20 20 20 20 20 id cid)).
0890: 20 28 73 65 74 21 20 28 63 75 72 72 65 6e 74 2d (set! (current-
08a0: 65 66 66 65 63 74 69 76 65 2d 75 73 65 72 2d 69 effective-user-i
08b0: 64 29 20 65 69 64 29 29 29 29 0a 0a 0a 28 64 65 d) eid))))...(de
08c0: 66 69 6e 65 20 28 72 75 6e 2d 63 6d 64 20 63 6d fine (run-cmd cm
08d0: 64 20 61 72 67 2d 6c 69 73 74 29 0a 20 20 3b 20 d arg-list). ;
08e0: 28 70 72 69 6e 74 20 28 63 75 72 72 65 6e 74 2d (print (current-
08f0: 65 66 66 65 63 74 69 76 65 2d 75 73 65 72 2d 69 effective-user-i
0900: 64 29 29 0a 20 20 20 3b 28 68 61 6e 64 6c 65 2d d)). ;(handle-
0910: 65 78 63 65 70 74 69 6f 6e 73 0a 3b 09 20 20 20 exceptions.;.
0920: 20 20 65 78 6e 0a 3b 09 20 20 20 20 20 28 70 72 exn.;. (pr
0930: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 66 61 int 0 "ERROR: fa
0940: 69 6c 65 64 20 74 6f 20 72 75 6e 20 73 63 72 69 iled to run scri
0950: 70 74 20 22 20 63 6d 64 20 22 20 77 69 74 68 20 pt " cmd " with
0960: 70 61 72 61 6d 73 20 22 20 61 72 67 2d 6c 69 73 params " arg-lis
0970: 74 20 22 20 22 20 28 65 78 6e 20 61 73 73 65 72 t " " (exn asser
0980: 74 29 29 0a 09 20 20 20 20 20 28 6c 65 74 20 28 t)).. (let (
0990: 28 70 69 64 20 28 70 72 6f 63 65 73 73 2d 72 75 (pid (process-ru
09a0: 6e 20 63 6d 64 20 61 72 67 2d 6c 69 73 74 29 29 n cmd arg-list))
09b0: 29 0a 09 20 20 20 20 20 20 20 28 70 72 6f 63 65 ).. (proce
09c0: 73 73 2d 77 61 69 74 20 70 69 64 29 29 0a 29 0a ss-wait pid)).).
09d0: 3b 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 65 ;)...(define (re
09e0: 67 73 74 65 72 2d 6c 6f 67 20 69 6e 6c 20 75 73 gster-log inl us
09f0: 72 2d 69 64 20 20 61 72 65 61 2d 69 64 20 20 63 r-id area-id c
0a00: 6d 64 29 0a 20 20 28 73 61 75 74 68 2d 63 6f 6d md). (sauth-com
0a10: 6d 6f 6e 3a 73 68 65 6c 6c 2d 64 6f 2d 61 73 2d mon:shell-do-as-
0a20: 61 64 6d 0a 20 20 20 20 20 20 20 20 28 6c 61 6d adm. (lam
0a30: 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 bda ().
0a40: 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 (sauthorize:db-d
0a50: 6f 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 o (lambda (db)
0a60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 . (s
0a70: 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 71 72 79 authorize:db-qry
0a80: 20 64 62 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 db (conc "INSER
0a90: 54 20 49 4e 54 4f 20 61 63 74 69 6f 6e 73 20 28 T INTO actions (
0aa0: 63 6d 64 2c 75 73 65 72 5f 69 64 2c 61 72 65 61 cmd,user_id,area
0ab0: 5f 69 64 2c 61 63 74 69 6f 6e 5f 74 79 70 65 20 _id,action_type
0ac0: 29 20 56 41 4c 55 45 53 20 28 27 73 72 65 74 72 ) VALUES ('sretr
0ad0: 69 65 76 65 20 22 20 69 6e 6c 20 22 27 2c 22 20 ieve " inl "',"
0ae0: 75 73 72 2d 69 64 20 22 2c 22 20 20 61 72 65 61 usr-id "," area
0af0: 2d 69 64 20 22 2c 20 27 63 61 74 27 20 29 22 29 -id ", 'cat' )")
0b00: 29 29 29 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b ))))))..;;;;;;;;
0b10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b20: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b30: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b40: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b50: 3b 0a 3b 20 43 68 65 63 6b 20 75 73 65 72 20 74 ;.; Check user t
0b60: 79 70 65 73 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ypes.;;;;;;;;;;;
0b70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b80: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b90: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0ba0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a ;;;;;;;;;;;;;;..
0bb0: 0a 0a 3b 3b 63 68 65 63 6b 20 69 66 20 61 20 75 ..;;check if a u
0bc0: 73 65 72 20 69 73 20 61 6e 20 61 64 6d 69 6e 0a ser is an admin.
0bd0: 28 64 65 66 69 6e 65 20 28 69 73 2d 61 64 6d 69 (define (is-admi
0be0: 6e 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 28 n username). (
0bf0: 6c 65 74 2a 20 28 28 61 64 6d 69 6e 20 23 66 29 let* ((admin #f)
0c00: 29 0a 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a ). (sauthoriz
0c10: 65 3a 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 e:db-do (lambda
0c20: 20 28 64 62 29 0a 20 20 20 20 20 20 20 20 28 6c (db). (l
0c30: 65 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 28 et* ((data-row (
0c40: 71 75 65 72 79 20 66 65 74 63 68 20 28 73 71 6c query fetch (sql
0c50: 20 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 db (conc "SELEC
0c60: 54 20 75 73 65 72 73 2e 69 73 5f 61 64 6d 69 6e T users.is_admin
0c70: 20 46 52 4f 4d 20 20 75 73 65 72 73 20 77 68 65 FROM users whe
0c80: 72 65 20 75 73 65 72 73 2e 75 73 65 72 6e 61 6d re users.usernam
0c90: 65 20 3d 20 27 22 20 75 73 65 72 6e 61 6d 65 20 e = '" username
0ca0: 22 27 22 29 29 29 29 29 0a 20 20 20 20 20 20 20 "'"))))).
0cb0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
0cc0: 20 64 61 74 61 2d 72 6f 77 29 29 0a 20 20 20 20 data-row)).
0cd0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
0ce0: 63 6f 6c 20 20 28 63 61 72 20 64 61 74 61 2d 72 col (car data-r
0cf0: 6f 77 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ow))).
0d00: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 (if (equal? c
0d10: 6f 6c 20 22 79 65 73 22 29 0a 20 20 20 20 20 20 ol "yes").
0d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
0d30: 74 21 20 61 64 6d 69 6e 20 23 74 29 29 29 29 29 t! admin #t)))))
0d40: 29 29 20 20 09 20 20 20 20 20 20 20 20 0a 61 64 )) . .ad
0d50: 6d 69 6e 29 29 0a 0a 0a 3b 3b 63 68 65 63 6b 20 min))...;;check
0d60: 69 66 20 61 20 75 73 65 72 20 69 73 20 61 6e 20 if a user is an
0d70: 72 65 61 64 2d 61 64 6d 69 6e 0a 28 64 65 66 69 read-admin.(defi
0d80: 6e 65 20 28 69 73 2d 72 65 61 64 2d 61 64 6d 69 ne (is-read-admi
0d90: 6e 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 28 n username). (
0da0: 6c 65 74 2a 20 28 28 61 64 6d 69 6e 20 23 66 29 let* ((admin #f)
0db0: 29 0a 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a ). (sauthoriz
0dc0: 65 3a 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 e:db-do (lambda
0dd0: 20 28 64 62 29 0a 20 20 20 20 20 20 20 20 28 6c (db). (l
0de0: 65 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 28 et* ((data-row (
0df0: 71 75 65 72 79 20 66 65 74 63 68 20 28 73 71 6c query fetch (sql
0e00: 20 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 db (conc "SELEC
0e10: 54 20 75 73 65 72 73 2e 69 73 5f 61 64 6d 69 6e T users.is_admin
0e20: 20 46 52 4f 4d 20 20 75 73 65 72 73 20 77 68 65 FROM users whe
0e30: 72 65 20 75 73 65 72 73 2e 75 73 65 72 6e 61 6d re users.usernam
0e40: 65 20 3d 20 27 22 20 75 73 65 72 6e 61 6d 65 20 e = '" username
0e50: 22 27 22 29 29 29 29 29 0a 20 20 20 20 20 20 20 "'"))))).
0e60: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
0e70: 20 64 61 74 61 2d 72 6f 77 29 29 0a 20 20 20 20 data-row)).
0e80: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
0e90: 63 6f 6c 20 20 28 63 61 72 20 64 61 74 61 2d 72 col (car data-r
0ea0: 6f 77 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ow))).
0eb0: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 (if (equal? c
0ec0: 6f 6c 20 22 72 65 61 64 2d 61 64 6d 69 6e 22 29 ol "read-admin")
0ed0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0ee0: 20 20 20 20 28 73 65 74 21 20 61 64 6d 69 6e 20 (set! admin
0ef0: 23 74 29 29 29 29 29 29 29 20 20 09 20 20 20 20 #t))))))) .
0f00: 20 20 20 20 0a 61 64 6d 69 6e 29 29 0a 0a 0a 3b .admin))...;
0f10: 3b 63 68 65 63 6b 20 69 66 20 75 73 65 72 20 68 ;check if user h
0f20: 61 73 20 73 70 65 63 69 66 63 20 72 6f 6c 65 20 as specifc role
0f30: 66 6f 72 20 61 20 61 72 65 61 0a 28 64 65 66 69 for a area.(defi
0f40: 6e 65 20 28 69 73 2d 75 73 65 72 20 72 6f 6c 65 ne (is-user role
0f50: 20 75 73 65 72 6e 61 6d 65 20 61 72 65 61 29 0a username area).
0f60: 20 20 28 6c 65 74 2a 20 28 28 68 61 73 2d 61 63 (let* ((has-ac
0f70: 63 65 73 73 20 23 66 29 29 0a 20 20 20 20 28 73 cess #f)). (s
0f80: 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 authorize:db-do
0f90: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
0fa0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 (let* ((da
0fb0: 74 61 2d 72 6f 77 20 28 71 75 65 72 79 20 66 65 ta-row (query fe
0fc0: 74 63 68 20 28 73 71 6c 20 64 62 20 28 63 6f 6e tch (sql db (con
0fd0: 63 20 22 53 45 4c 45 43 54 20 20 70 65 72 6d 69 c "SELECT permi
0fe0: 73 73 69 6f 6e 73 2e 61 63 63 65 73 73 5f 74 79 ssions.access_ty
0ff0: 70 65 2c 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e pe, permissions.
1000: 65 78 70 69 72 61 74 69 6f 6e 20 46 52 4f 4d 20 expiration FROM
1010: 20 75 73 65 72 73 20 2c 20 20 61 72 65 61 73 2c users , areas,
1020: 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 77 68 65 permissions whe
1030: 72 65 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 75 re permissions.u
1040: 73 65 72 5f 69 64 20 3d 20 75 73 65 72 73 2e 69 ser_id = users.i
1050: 64 20 61 6e 64 20 70 65 72 6d 69 73 73 69 6f 6e d and permission
1060: 73 2e 61 72 65 61 5f 69 64 20 3d 20 61 72 65 61 s.area_id = area
1070: 73 2e 69 64 20 61 6e 64 20 75 73 65 72 73 2e 75 s.id and users.u
1080: 73 65 72 6e 61 6d 65 20 3d 20 27 22 20 75 73 65 sername = '" use
1090: 72 6e 61 6d 65 20 22 27 20 61 6e 64 20 61 72 65 rname "' and are
10a0: 61 73 2e 63 6f 64 65 20 3d 20 27 22 20 61 72 65 as.code = '" are
10b0: 61 20 22 27 22 29 29 29 29 29 0a 20 20 20 20 20 a "'"))))).
10c0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
10d0: 6c 3f 20 64 61 74 61 2d 72 6f 77 29 29 0a 20 20 l? data-row)).
10e0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
10f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1100: 6c 65 74 2a 20 28 28 61 63 63 65 73 73 2d 74 79 let* ((access-ty
1110: 70 65 20 20 28 63 61 72 20 64 61 74 61 2d 72 6f pe (car data-ro
1120: 77 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 w)).
1130: 20 20 20 20 20 20 20 20 28 65 78 64 61 74 65 20 (exdate
1140: 28 63 61 64 72 20 64 61 74 61 2d 72 6f 77 29 29 (cadr data-row))
1150: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1160: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
1170: 20 65 78 64 61 74 65 29 29 20 0a 20 20 20 20 20 exdate)) .
1180: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
1190: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11a0: 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 69 64 (let ((valid
11b0: 20 28 69 73 2d 61 63 63 65 73 73 2d 76 61 6c 69 (is-access-vali
11c0: 64 20 20 65 78 64 61 74 65 29 29 29 0a 20 20 20 d exdate))).
11d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11e0: 3b 28 70 72 69 6e 74 20 76 61 6c 69 64 29 20 0a ;(print valid) .
11f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1200: 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 (if (and (equa
1210: 6c 3f 20 61 63 63 65 73 73 2d 74 79 70 65 20 72 l? access-type r
1220: 6f 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ole).
1230: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 71 (eq
1240: 75 61 6c 3f 20 76 61 6c 69 64 20 23 74 29 29 0a ual? valid #t)).
1250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1260: 20 20 20 28 73 65 74 21 20 68 61 73 2d 61 63 63 (set! has-acc
1270: 65 73 73 20 23 74 29 29 29 29 0a 20 20 20 20 20 ess #t)))).
1280: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
1290: 74 20 22 41 63 63 65 73 73 20 65 78 70 69 72 65 t "Access expire
12a0: 64 22 29 29 29 29 29 29 29 29 0a 20 3b 28 70 72 d")))))))). ;(pr
12b0: 69 6e 74 20 68 61 73 2d 61 63 63 65 73 73 29 0a int has-access).
12c0: 68 61 73 2d 61 63 63 65 73 73 29 29 0a 0a 28 64 has-access))..(d
12d0: 65 66 69 6e 65 20 28 69 73 2d 61 63 63 65 73 73 efine (is-access
12e0: 2d 76 61 6c 69 64 20 65 78 70 2d 73 74 72 29 0a -valid exp-str).
12f0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 74 2d (let* ((ret-
1300: 76 61 6c 20 23 66 20 29 0a 20 20 20 20 20 20 20 val #f ).
1310: 20 20 20 20 28 64 61 74 65 2d 70 61 72 74 73 20 (date-parts
1320: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 65 (string-split e
1330: 78 70 2d 73 74 72 20 22 2f 22 29 29 0a 20 20 20 xp-str "/")).
1340: 20 20 20 20 20 20 20 20 28 79 72 20 28 73 74 72 (yr (str
1350: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 72 ing->number (car
1360: 20 64 61 74 65 2d 70 61 72 74 73 29 29 29 0a 20 date-parts))).
1370: 20 20 20 20 20 20 20 20 20 20 28 6d 6f 6e 74 68 (month
1380: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
1390: 28 63 61 72 20 28 63 64 72 20 64 61 74 65 2d 70 (car (cdr date-p
13a0: 61 72 74 73 29 29 29 29 20 0a 20 20 20 20 20 20 arts)))) .
13b0: 20 20 20 20 20 28 64 61 79 20 28 73 74 72 69 6e (day (strin
13c0: 67 2d 3e 6e 75 6d 62 65 72 28 63 61 64 64 72 20 g->number(caddr
13d0: 64 61 74 65 2d 70 61 72 74 73 29 29 29 0a 20 20 date-parts))).
13e0: 20 20 20 20 20 20 20 20 20 28 65 78 70 2d 64 61 (exp-da
13f0: 74 65 20 28 6d 61 6b 65 2d 64 61 74 65 20 30 20 te (make-date 0
1400: 30 20 30 20 30 20 64 61 79 20 6d 6f 6e 74 68 20 0 0 0 day month
1410: 79 72 20 29 29 29 0a 20 20 20 20 20 20 20 20 20 yr ))).
1420: 20 20 20 20 3b 28 70 72 69 6e 74 20 20 65 78 70 ;(print exp
1430: 2d 64 61 74 65 29 0a 20 20 20 20 20 20 20 20 20 -date).
1440: 20 20 20 20 3b 28 70 72 69 6e 74 20 28 63 75 72 ;(print (cur
1450: 72 65 6e 74 2d 64 61 74 65 29 29 20 20 20 0a 20 rent-date)) .
1460: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
1470: 3e 20 28 64 61 74 65 2d 63 6f 6d 70 61 72 65 20 > (date-compare
1480: 65 78 70 2d 64 61 74 65 20 20 28 63 75 72 72 65 exp-date (curre
1490: 6e 74 2d 64 61 74 65 29 29 20 30 29 0a 20 20 20 nt-date)) 0).
14a0: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
14b0: 72 65 74 2d 76 61 6c 20 23 74 29 29 0a 20 20 20 ret-val #t)).
14c0: 3b 28 70 72 69 6e 74 20 72 65 74 2d 76 61 6c 29 ;(print ret-val)
14d0: 0a 20 20 20 72 65 74 2d 76 61 6c 29 29 0a 0a 0a . ret-val))...
14e0: 3b 63 68 65 63 6b 20 69 66 20 61 72 65 61 20 65 ;check if area e
14f0: 78 69 73 74 73 0a 28 64 65 66 69 6e 65 20 28 61 xists.(define (a
1500: 72 65 61 2d 65 78 69 73 74 73 20 61 72 65 61 29 rea-exists area)
1510: 0a 20 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 . (let* ((area
1520: 2d 64 65 66 69 6e 65 64 20 23 66 29 29 0a 20 20 -defined #f)).
1530: 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 (sauthorize:db
1540: 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 62 -do (lambda (db
1550: 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ). (let*
1560: 28 28 64 61 74 61 2d 72 6f 77 20 28 71 75 65 72 ((data-row (quer
1570: 79 20 66 65 74 63 68 20 28 73 71 6c 20 64 62 20 y fetch (sql db
1580: 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 20 69 (conc "SELECT i
1590: 64 20 46 52 4f 4d 20 20 61 72 65 61 73 20 77 68 d FROM areas wh
15a0: 65 72 65 20 61 72 65 61 73 2e 63 6f 64 65 20 3d ere areas.code =
15b0: 20 27 22 20 61 72 65 61 20 22 27 22 29 29 29 29 '" area "'"))))
15c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 66 ). (if
15d0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 64 61 74 (not (null? dat
15e0: 61 2d 72 6f 77 29 29 0a 20 20 20 20 20 20 20 20 a-row)).
15f0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 61 (set! a
1600: 72 65 61 2d 64 65 66 69 6e 65 64 20 23 74 29 29 rea-defined #t))
1610: 29 29 29 0a 61 72 65 61 2d 64 65 66 69 6e 65 64 ))).area-defined
1620: 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ))..;;;;;;;;;;;;
1630: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1640: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1650: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1660: 3b 3b 3b 0a 3b 20 47 65 74 20 52 65 63 6f 72 64 ;;;.; Get Record
1670: 20 66 72 6f 6d 20 64 61 74 61 62 61 73 65 0a 3b from database.;
1680: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1690: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
16a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
16b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a ;;;;;;;;;;;;;;..
16c0: 3b 67 65 74 73 20 61 72 65 61 20 69 64 20 62 79 ;gets area id by
16d0: 20 63 6f 64 65 20 0a 28 64 65 66 69 6e 65 20 28 code .(define (
16e0: 67 65 74 2d 61 72 65 61 20 61 72 65 61 29 0a 20 get-area area).
16f0: 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 2d 64 (let* ((area-d
1700: 65 66 69 6e 65 64 20 27 28 29 29 29 0a 20 20 20 efined '())).
1710: 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d (sauthorize:db-
1720: 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 do (lambda (db)
1730: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
1740: 28 64 61 74 61 2d 72 6f 77 20 28 71 75 65 72 79 (data-row (query
1750: 20 66 65 74 63 68 20 28 73 71 6c 20 64 62 20 28 fetch (sql db (
1760: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 20 69 64 conc "SELECT id
1770: 20 46 52 4f 4d 20 20 61 72 65 61 73 20 77 68 65 FROM areas whe
1780: 72 65 20 61 72 65 61 73 2e 63 6f 64 65 20 3d 20 re areas.code =
1790: 27 22 20 61 72 65 61 20 22 27 22 29 29 29 29 29 '" area "'")))))
17a0: 0a 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 . (set!
17b0: 20 20 61 72 65 61 2d 64 65 66 69 6e 65 64 20 64 area-defined d
17c0: 61 74 61 2d 72 6f 77 29 29 29 29 0a 61 72 65 61 ata-row)))).area
17d0: 2d 64 65 66 69 6e 65 64 29 29 0a 0a 3b 67 65 74 -defined))..;get
17e0: 20 69 64 20 6f 66 20 75 73 65 72 73 20 74 61 62 id of users tab
17f0: 6c 65 20 62 79 20 75 73 65 72 20 6e 61 6d 65 20 le by user name
1800: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 73 .(define (get-us
1810: 65 72 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a er user). (let*
1820: 20 28 28 75 73 65 72 2d 64 65 66 69 6e 65 64 20 ((user-defined
1830: 27 28 29 29 29 0a 20 20 20 20 28 73 61 75 74 68 '())). (sauth
1840: 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 28 6c 61 orize:db-do (la
1850: 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 mbda (db).
1860: 20 20 28 6c 65 74 2a 20 28 28 64 61 74 61 2d 72 (let* ((data-r
1870: 6f 77 20 28 71 75 65 72 79 20 66 65 74 63 68 20 ow (query fetch
1880: 28 73 71 6c 20 64 62 20 28 63 6f 6e 63 20 22 53 (sql db (conc "S
1890: 45 4c 45 43 54 20 20 69 64 20 46 52 4f 4d 20 20 ELECT id FROM
18a0: 75 73 65 72 73 20 77 68 65 72 65 20 75 73 65 72 users where user
18b0: 73 2e 75 73 65 72 6e 61 6d 65 20 3d 20 27 22 20 s.username = '"
18c0: 75 73 65 72 20 22 27 22 29 29 29 29 29 0a 20 20 user "'"))))).
18d0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 20 75 (set! u
18e0: 73 65 72 2d 64 65 66 69 6e 65 64 20 64 61 74 61 ser-defined data
18f0: 2d 72 6f 77 29 29 29 29 0a 75 73 65 72 2d 64 65 -row)))).user-de
1900: 66 69 6e 65 64 29 29 0a 0a 3b 67 65 74 20 70 65 fined))..;get pe
1910: 72 6d 69 73 73 69 6f 6e 73 20 69 64 20 62 79 20 rmissions id by
1920: 75 73 65 72 69 64 20 61 6e 64 20 61 72 65 61 20 userid and area
1930: 69 64 20 0a 28 64 65 66 69 6e 65 20 28 67 65 74 id .(define (get
1940: 2d 70 65 72 6d 20 75 73 65 72 69 64 20 61 72 65 -perm userid are
1950: 61 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 aid). (let* ((u
1960: 73 65 72 2d 64 65 66 69 6e 65 64 20 27 28 29 29 ser-defined '())
1970: 29 0a 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a ). (sauthoriz
1980: 65 3a 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 e:db-do (lambda
1990: 20 28 64 62 29 0a 20 20 20 20 20 20 20 20 20 20 (db).
19a0: 28 6c 65 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 (let* ((data-row
19b0: 20 28 71 75 65 72 79 20 66 65 74 63 68 20 28 73 (query fetch (s
19c0: 71 6c 20 64 62 20 28 63 6f 6e 63 20 22 53 45 4c ql db (conc "SEL
19d0: 45 43 54 20 20 69 64 20 46 52 4f 4d 20 20 70 65 ECT id FROM pe
19e0: 72 6d 69 73 73 69 6f 6e 73 20 77 68 65 72 65 20 rmissions where
19f0: 75 73 65 72 5f 69 64 20 3d 20 22 20 75 73 65 72 user_id = " user
1a00: 69 64 20 22 20 61 6e 64 20 61 72 65 61 5f 69 64 id " and area_id
1a10: 20 3d 20 22 20 61 72 65 61 69 64 29 29 29 29 29 = " areaid)))))
1a20: 0a 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 . (set!
1a30: 20 75 73 65 72 2d 64 65 66 69 6e 65 64 20 64 61 user-defined da
1a40: 74 61 2d 72 6f 77 29 29 29 29 0a 0a 75 73 65 72 ta-row))))..user
1a50: 2d 64 65 66 69 6e 65 64 29 29 0a 0a 28 64 65 66 -defined))..(def
1a60: 69 6e 65 20 28 67 65 74 2d 72 65 73 74 72 69 63 ine (get-restric
1a70: 74 69 6f 6e 73 20 62 61 73 65 2d 70 61 74 68 20 tions base-path
1a80: 75 73 72 29 0a 28 6c 65 74 2a 20 28 28 75 73 65 usr).(let* ((use
1a90: 72 2d 64 65 66 69 6e 65 64 20 27 28 29 29 29 0a r-defined '())).
1aa0: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
1ab0: 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 db-do (lambda (
1ac0: 64 62 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c db). (l
1ad0: 65 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 28 et* ((data-row (
1ae0: 71 75 65 72 79 20 66 65 74 63 68 20 28 73 71 6c query fetch (sql
1af0: 20 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 db (conc "SELEC
1b00: 54 20 20 72 65 73 74 72 69 63 74 69 6f 6e 20 46 T restriction F
1b10: 52 4f 4d 20 61 72 65 61 73 2c 20 75 73 65 72 73 ROM areas, users
1b20: 2c 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 77 68 , permissions wh
1b30: 65 72 65 20 20 61 72 65 61 73 2e 69 64 20 3d 20 ere areas.id =
1b40: 70 65 72 6d 69 73 73 69 6f 6e 73 2e 61 72 65 61 permissions.area
1b50: 5f 69 64 20 61 6e 64 20 75 73 65 72 73 2e 69 64 _id and users.id
1b60: 20 3d 20 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e = permissions.
1b70: 75 73 65 72 5f 69 64 20 61 6e 64 20 20 75 73 65 user_id and use
1b80: 72 73 2e 75 73 65 72 6e 61 6d 65 20 3d 20 27 22 rs.username = '"
1b90: 20 75 73 72 20 22 27 20 61 6e 64 20 61 72 65 61 usr "' and area
1ba0: 73 2e 62 61 73 65 70 61 74 68 20 3d 20 27 22 20 s.basepath = '"
1bb0: 62 61 73 65 2d 70 61 74 68 20 22 27 22 29 29 29 base-path "'")))
1bc0: 29 29 0a 20 20 20 20 20 20 20 20 20 3b 28 70 72 )). ;(pr
1bd0: 69 6e 74 20 64 61 74 61 2d 72 6f 77 29 20 0a 20 int data-row) .
1be0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 20 75 (set! u
1bf0: 73 65 72 2d 64 65 66 69 6e 65 64 20 64 61 74 61 ser-defined data
1c00: 2d 72 6f 77 29 29 29 29 0a 20 20 20 20 3b 20 20 -row)))). ;
1c10: 20 28 70 72 69 6e 74 20 75 73 65 72 2d 64 65 66 (print user-def
1c20: 69 6e 65 64 29 0a 20 20 28 69 66 20 28 6e 75 6c ined). (if (nul
1c30: 6c 3f 20 75 73 65 72 2d 64 65 66 69 6e 65 64 29 l? user-defined)
1c40: 0a 20 20 20 20 20 20 22 22 0a 20 20 20 20 20 20 . "".
1c50: 28 63 61 72 20 75 73 65 72 2d 64 65 66 69 6e 65 (car user-define
1c60: 64 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 d))))...(define
1c70: 28 67 65 74 2d 6f 62 6a 2d 62 79 2d 70 61 74 68 (get-obj-by-path
1c80: 20 70 61 74 68 29 0a 20 20 20 28 6c 65 74 2a 20 path). (let*
1c90: 28 28 6f 62 6a 20 27 28 29 29 29 0a 20 20 20 20 ((obj '())).
1ca0: 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 (sauthorize:db-d
1cb0: 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a o (lambda (db).
1cc0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
1cd0: 64 61 74 61 2d 72 6f 77 20 28 71 75 65 72 79 20 data-row (query
1ce0: 66 65 74 63 68 20 28 73 71 6c 20 64 62 20 28 63 fetch (sql db (c
1cf0: 6f 6e 63 20 22 53 45 4c 45 43 54 20 20 63 6f 64 onc "SELECT cod
1d00: 65 2c 65 78 65 5f 6e 61 6d 65 2c 20 69 64 2c 20 e,exe_name, id,
1d10: 62 61 73 65 70 61 74 68 20 46 52 4f 4d 20 20 61 basepath FROM a
1d20: 72 65 61 73 20 77 68 65 72 65 20 61 72 65 61 73 reas where areas
1d30: 2e 62 61 73 65 70 61 74 68 20 3d 20 27 22 20 70 .basepath = '" p
1d40: 61 74 68 20 22 27 22 29 29 29 29 29 0a 20 20 20 ath "'"))))).
1d50: 20 20 20 20 20 20 28 73 65 74 21 20 20 6f 62 6a (set! obj
1d60: 20 64 61 74 61 2d 72 6f 77 29 29 29 29 0a 6f 62 data-row)))).ob
1d70: 6a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 j))..(define (ge
1d80: 74 2d 6f 62 6a 2d 62 79 2d 63 6f 64 65 20 63 6f t-obj-by-code co
1d90: 64 65 20 29 0a 20 20 28 6c 65 74 2a 20 28 28 6f de ). (let* ((o
1da0: 62 6a 20 27 28 29 29 29 0a 20 20 20 20 28 73 61 bj '())). (sa
1db0: 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 uthorize:db-do
1dc0: 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 (lambda (db).
1dd0: 20 20 20 20 20 3b 28 70 72 69 6e 74 20 28 63 6f ;(print (co
1de0: 6e 63 20 22 53 45 4c 45 43 54 20 20 63 6f 64 65 nc "SELECT code
1df0: 2c 20 65 78 65 5f 6e 61 6d 65 2c 20 20 69 64 2c , exe_name, id,
1e00: 20 62 61 73 65 70 61 74 68 2c 20 72 65 71 75 69 basepath, requi
1e10: 72 65 64 5f 67 72 70 73 20 20 46 52 4f 4d 20 20 red_grps FROM
1e20: 61 72 65 61 73 20 77 68 65 72 65 20 61 72 65 61 areas where area
1e30: 73 2e 63 6f 64 65 20 3d 20 27 22 20 63 6f 64 65 s.code = '" code
1e40: 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 20 28 "'")). (
1e50: 6c 65 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 let* ((data-row
1e60: 28 71 75 65 72 79 20 66 65 74 63 68 20 28 73 71 (query fetch (sq
1e70: 6c 20 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 l db (conc "SELE
1e80: 43 54 20 20 63 6f 64 65 2c 20 65 78 65 5f 6e 61 CT code, exe_na
1e90: 6d 65 2c 20 20 69 64 2c 20 62 61 73 65 70 61 74 me, id, basepat
1ea0: 68 2c 20 72 65 71 75 69 72 65 64 5f 67 72 70 73 h, required_grps
1eb0: 20 20 46 52 4f 4d 20 20 61 72 65 61 73 20 77 68 FROM areas wh
1ec0: 65 72 65 20 61 72 65 61 73 2e 63 6f 64 65 20 3d ere areas.code =
1ed0: 20 27 22 20 63 6f 64 65 20 22 27 22 29 29 29 29 '" code "'"))))
1ee0: 29 0a 20 20 20 20 20 20 20 20 20 3b 28 70 72 69 ). ;(pri
1ef0: 6e 74 20 64 61 74 61 2d 72 6f 77 29 0a 20 20 20 nt data-row).
1f00: 20 20 20 20 20 20 28 73 65 74 21 20 20 6f 62 6a (set! obj
1f10: 20 64 61 74 61 2d 72 6f 77 29 0a 20 20 20 20 20 data-row).
1f20: 20 20 20 20 3b 28 70 72 69 6e 74 20 6f 62 6a 29 ;(print obj)
1f30: 20 0a 20 20 20 20 20 20 20 20 29 29 29 0a 20 20 . ))).
1f40: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
1f50: 3f 20 6f 62 6a 29 29 0a 20 20 20 20 20 20 20 20 ? obj)).
1f60: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
1f70: 20 20 20 28 6c 65 74 2a 20 28 28 72 65 71 2d 67 (let* ((req-g
1f80: 72 70 20 28 63 61 64 64 72 20 28 63 64 64 72 20 rp (caddr (cddr
1f90: 6f 62 6a 29 29 29 29 0a 20 20 20 20 20 20 20 20 obj)))).
1fa0: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
1fb0: 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 do-as-calling-us
1fc0: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er.
1fd0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 28 73 61 75 (lambda (). (sau
1fe0: 74 68 2d 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d th-common:check-
1ff0: 75 73 65 72 2d 67 72 6f 75 70 73 20 72 65 71 2d user-groups req-
2000: 67 72 70 29 29 29 29 29 29 0a 6f 62 6a 29 29 0a grp)))))).obj)).
2010: 0a 28 64 65 66 69 6e 65 20 28 73 61 75 74 68 2d .(define (sauth-
2020: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 75 73 65 common:check-use
2030: 72 2d 67 72 6f 75 70 73 20 72 65 71 2d 67 72 70 r-groups req-grp
2040: 29 0a 28 6c 65 74 2a 20 28 28 63 75 72 72 65 6e ).(let* ((curren
2050: 74 2d 67 72 6f 75 70 73 20 20 28 67 65 74 2d 67 t-groups (get-g
2060: 72 6f 75 70 73 29 20 29 0a 20 20 20 20 20 20 20 roups) ).
2070: 20 28 72 65 71 2d 67 72 70 2d 6c 69 73 74 20 28 (req-grp-list (
2080: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 65 71 string-split req
2090: 2d 67 72 70 20 22 2c 22 29 29 29 0a 20 20 20 20 -grp ","))).
20a0: 20 20 20 20 3b 28 70 72 69 6e 74 20 72 65 71 2d ;(print req-
20b0: 67 72 70 2d 6c 69 73 74 29 0a 20 20 20 20 20 20 grp-list).
20c0: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
20d0: 62 64 61 20 28 67 72 70 29 0a 09 20 20 28 6c 65 bda (grp).. (le
20e0: 74 20 28 28 67 72 70 2d 69 6e 66 6f 20 28 67 72 t ((grp-info (gr
20f0: 6f 75 70 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 oup-information
2100: 67 72 70 29 29 29 0a 20 20 20 20 20 20 20 20 20 grp))).
2110: 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 67 72 ;(print gr
2120: 70 2d 69 6e 66 6f 20 22 20 22 20 67 72 70 29 0a p-info " " grp).
2130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2140: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
2150: 67 72 70 2d 69 6e 66 6f 20 23 66 29 29 0a 20 20 grp-info #f)).
2160: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
2170: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
2180: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6d (if (not (m
2190: 65 6d 62 65 72 20 20 28 63 61 64 64 72 20 67 72 ember (caddr gr
21a0: 70 2d 69 6e 66 6f 29 20 63 75 72 72 65 6e 74 2d p-info) current-
21b0: 67 72 6f 75 70 73 29 29 0a 20 20 20 20 20 20 20 groups)).
21c0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
21d0: 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
21e0: 20 20 20 20 20 20 20 28 73 61 75 74 68 3a 70 72 (sauth:pr
21f0: 69 6e 74 2d 65 72 72 6f 72 20 28 63 6f 6e 63 20 int-error (conc
2200: 22 50 6c 65 61 73 65 20 77 61 73 68 20 22 20 67 "Please wash " g
2210: 72 70 20 22 20 67 72 6f 75 70 20 69 6e 20 79 6f rp " group in yo
2220: 75 72 20 78 74 65 72 6d 21 21 20 22 20 29 29 0a ur xterm!! " )).
2230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2240: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 (exit 1))))
2250: 29 29 29 0a 09 20 20 20 20 20 72 65 71 2d 67 72 ))).. req-gr
2260: 70 2d 6c 69 73 74 29 29 29 0a 0a 28 64 65 66 69 p-list)))..(defi
2270: 6e 65 20 28 67 65 74 2d 6f 62 6a 2d 62 79 2d 63 ne (get-obj-by-c
2280: 6f 64 65 2d 6e 6f 2d 67 72 70 2d 76 61 6c 69 64 ode-no-grp-valid
2290: 61 74 69 6f 6e 20 63 6f 64 65 20 29 0a 20 20 28 ation code ). (
22a0: 6c 65 74 2a 20 28 28 6f 62 6a 20 27 28 29 29 29 let* ((obj '()))
22b0: 0a 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 . (sauthorize
22c0: 3a 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 :db-do (lambda
22d0: 28 64 62 29 0a 20 20 20 20 20 20 20 20 28 6c 65 (db). (le
22e0: 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 28 71 t* ((data-row (q
22f0: 75 65 72 79 20 66 65 74 63 68 20 28 73 71 6c 20 uery fetch (sql
2300: 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 db (conc "SELECT
2310: 20 20 63 6f 64 65 2c 20 65 78 65 5f 6e 61 6d 65 code, exe_name
2320: 2c 20 20 69 64 2c 20 62 61 73 65 70 61 74 68 20 , id, basepath
2330: 20 46 52 4f 4d 20 20 61 72 65 61 73 20 77 68 65 FROM areas whe
2340: 72 65 20 61 72 65 61 73 2e 63 6f 64 65 20 3d 20 re areas.code =
2350: 27 22 20 63 6f 64 65 20 22 27 22 29 29 29 29 29 '" code "'")))))
2360: 0a 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 . (set!
2370: 20 6f 62 6a 20 64 61 74 61 2d 72 6f 77 29 29 29 obj data-row)))
2380: 29 0a 3b 28 70 72 69 6e 74 20 6f 62 6a 29 0a 6f ).;(print obj).o
2390: 62 6a 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 bj))...(define (
23a0: 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 73 72 63 sauth-common:src
23b0: 2d 73 69 7a 65 20 70 61 74 68 29 0a 20 20 28 6c -size path). (l
23c0: 65 74 20 28 28 6f 75 74 70 75 74 20 28 77 69 74 et ((output (wit
23d0: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
23e0: 65 20 28 63 6f 6e 63 20 22 2f 75 73 72 2f 62 69 e (conc "/usr/bi
23f0: 6e 2f 64 75 20 2d 73 20 22 20 70 61 74 68 20 20 n/du -s " path
2400: 22 20 20 7c 20 61 77 6b 20 27 7b 70 72 69 6e 74 " | awk '{print
2410: 20 24 31 7d 27 22 29 20 20 0a 20 20 20 20 20 20 $1}'") .
2420: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
2430: 64 61 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 da().
2440: 20 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e (read-lin
2450: 65 29 29 29 29 29 0a 20 20 20 20 20 20 28 73 74 e))))). (st
2460: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6f 75 74 ring->number out
2470: 70 75 74 29 29 29 20 20 0a 0a 28 64 65 66 69 6e put))) ..(defin
2480: 65 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a e (sauth-common:
2490: 73 70 61 63 65 2d 6c 65 66 74 2d 61 74 2d 64 65 space-left-at-de
24a0: 73 74 20 70 61 74 68 29 0a 20 20 20 28 6c 65 74 st path). (let
24b0: 2a 20 28 28 6f 75 74 70 75 74 20 20 28 72 75 6e * ((output (run
24c0: 2f 73 74 72 69 6e 67 20 28 70 69 70 65 20 28 64 /string (pipe (d
24d0: 66 20 2c 70 61 74 68 20 29 20 28 74 61 69 6c 20 f ,path ) (tail
24e0: 2d 31 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 -1)))).
24f0: 28 73 69 7a 65 20 28 63 61 64 64 72 20 28 63 64 (size (caddr (cd
2500: 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 r (string-split
2510: 6f 75 74 70 75 74 20 22 20 22 29 29 29 29 29 0a output " "))))).
2520: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
2530: 72 20 73 69 7a 65 29 29 29 0a 0a 3b 3b 20 66 75 r size)))..;; fu
2540: 6e 63 74 69 6f 6e 20 74 6f 20 76 61 6c 69 64 61 nction to valida
2550: 74 65 20 74 68 65 20 75 73 65 72 73 20 69 6e 70 te the users inp
2560: 75 74 20 66 6f 72 20 74 61 72 67 65 74 20 70 61 ut for target pa
2570: 74 68 20 61 6e 64 20 72 65 73 6f 6c 76 65 20 74 th and resolve t
2580: 68 65 20 70 61 74 68 0a 3b 3b 20 54 4f 44 4f 3a he path.;; TODO:
2590: 20 43 68 65 63 6b 20 66 6f 72 20 72 65 73 74 72 Check for restr
25a0: 69 63 74 69 6f 6e 20 69 6e 20 73 75 62 70 61 74 iction in subpat
25b0: 68 20 0a 28 64 65 66 69 6e 65 20 28 73 61 75 74 h .(define (saut
25c0: 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 h-common:resolve
25d0: 2d 70 61 74 68 20 20 6e 65 77 20 63 75 72 72 65 -path new curre
25e0: 6e 74 20 61 6c 6c 6f 77 65 64 2d 73 68 65 65 74 nt allowed-sheet
25f0: 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 74 61 s). (let* ((ta
2600: 72 67 65 74 2d 70 61 74 68 20 28 61 70 70 65 6e rget-path (appen
2610: 64 20 20 63 75 72 72 65 6e 74 20 28 73 74 72 69 d current (stri
2620: 6e 67 2d 73 70 6c 69 74 20 6e 65 77 20 22 2f 22 ng-split new "/"
2630: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 74 ))). (t
2640: 61 72 67 65 74 2d 70 61 74 68 2d 73 74 72 69 6e arget-path-strin
2650: 67 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 g (string-join t
2660: 61 72 67 65 74 2d 70 61 74 68 20 22 2f 22 29 29 arget-path "/"))
2670: 0a 20 20 20 20 20 20 20 20 20 20 28 6e 6f 72 6d . (norm
2680: 61 6c 2d 70 61 74 68 20 28 6e 6f 72 6d 61 6c 69 al-path (normali
2690: 7a 65 2d 70 61 74 68 6e 61 6d 65 20 74 61 72 67 ze-pathname targ
26a0: 65 74 2d 70 61 74 68 2d 73 74 72 69 6e 67 29 29 et-path-string))
26b0: 0a 20 20 20 20 20 20 20 20 20 20 28 6e 6f 72 6d . (norm
26c0: 61 6c 2d 6c 69 73 74 20 28 73 74 72 69 6e 67 2d al-list (string-
26d0: 73 70 6c 69 74 20 6e 6f 72 6d 61 6c 2d 70 61 74 split normal-pat
26e0: 68 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 h "/")).
26f0: 20 20 20 28 72 65 74 20 27 28 29 29 29 0a 20 20 (ret '())).
2700: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 63 6f 6e (if (string-con
2710: 74 61 69 6e 73 20 20 20 6e 6f 72 6d 61 6c 2d 70 tains normal-p
2720: 61 74 68 20 22 2e 2e 22 29 0a 20 20 20 20 28 62 ath ".."). (b
2730: 65 67 69 6e 0a 20 20 20 20 20 20 28 70 72 69 6e egin. (prin
2740: 74 20 22 45 52 52 4f 52 3a 20 50 61 74 68 20 20 t "ERROR: Path
2750: 22 20 6e 65 77 20 22 20 72 65 73 6f 6c 76 65 64 " new " resolved
2760: 20 6f 75 74 73 69 64 65 20 74 61 72 67 65 74 20 outside target
2770: 61 72 65 61 20 22 29 0a 20 20 20 20 20 20 23 66 area "). #f
2780: 29 0a 20 20 20 20 28 69 66 28 65 71 75 61 6c 3f ). (if(equal?
2790: 20 6e 6f 72 6d 61 6c 2d 70 61 74 68 20 22 2e 22 normal-path "."
27a0: 29 0a 20 20 20 20 20 20 72 65 74 20 20 0a 20 20 ). ret .
27b0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 (if (not (memb
27c0: 65 72 20 20 28 63 61 72 20 6e 6f 72 6d 61 6c 2d er (car normal-
27d0: 6c 69 73 74 29 20 61 6c 6c 6f 77 65 64 2d 73 68 list) allowed-sh
27e0: 65 65 74 73 29 29 0a 20 20 20 20 20 20 28 62 65 eets)). (be
27f0: 67 69 6e 0a 20 20 20 20 20 20 28 70 72 69 6e 74 gin. (print
2800: 20 22 45 52 52 4f 52 3a 20 50 65 72 6d 69 73 69 "ERROR: Permisi
2810: 6f 6e 20 64 65 6e 69 65 64 20 74 6f 20 20 22 20 on denied to "
2820: 6e 65 77 20 29 0a 20 20 20 20 20 20 20 23 66 29 new ). #f)
2830: 0a 20 20 20 20 6e 6f 72 6d 61 6c 2d 6c 69 73 74 . normal-list
2840: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
2850: 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 67 65 74 sauth-common:get
2860: 2d 74 61 72 67 65 74 2d 70 61 74 68 20 62 61 73 -target-path bas
2870: 65 2d 70 61 74 68 2d 6c 69 73 74 20 65 78 74 2d e-path-list ext-
2880: 70 61 74 68 20 74 6f 70 2d 61 72 65 61 73 20 62 path top-areas b
2890: 61 73 65 2d 70 61 74 68 29 0a 20 20 28 6c 65 74 ase-path). (let
28a0: 2a 20 28 28 72 65 73 6f 6c 76 65 64 2d 70 61 74 * ((resolved-pat
28b0: 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a h (sauth-common:
28c0: 72 65 73 6f 6c 76 65 2d 70 61 74 68 20 65 78 74 resolve-path ext
28d0: 2d 70 61 74 68 20 62 61 73 65 2d 70 61 74 68 2d -path base-path-
28e0: 6c 69 73 74 20 74 6f 70 2d 61 72 65 61 73 20 29 list top-areas )
28f0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 75 73 72 ). (usr
2900: 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e (current-user-n
2910: 61 6d 65 29 20 29 20 29 0a 20 20 20 20 20 20 20 ame) ) ).
2920: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 (if (not (equ
2930: 61 6c 3f 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 al? resolved-pat
2940: 68 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 h #f)).
2950: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 73 (if (null? res
2960: 6f 6c 76 65 64 2d 70 61 74 68 29 20 0a 20 20 20 olved-path) .
2970: 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 #f.
2980: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
2990: 73 68 65 65 74 20 28 63 61 72 20 72 65 73 6f 6c sheet (car resol
29a0: 76 65 64 2d 70 61 74 68 29 29 0a 20 20 20 20 20 ved-path)).
29b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
29c0: 65 73 74 72 69 63 74 65 64 2d 61 72 65 61 73 20 estricted-areas
29d0: 28 67 65 74 2d 72 65 73 74 72 69 63 74 69 6f 6e (get-restriction
29e0: 73 20 62 61 73 65 2d 70 61 74 68 20 75 73 72 29 s base-path usr)
29f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2a00: 20 20 20 20 20 28 72 65 73 74 72 69 63 74 69 6f (restrictio
2a10: 6e 73 20 28 63 6f 6e 63 20 22 2e 2a 22 20 28 73 ns (conc ".*" (s
2a20: 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 73 74 72 69 tring-join (stri
2a30: 6e 67 2d 73 70 6c 69 74 20 72 65 73 74 72 69 63 ng-split restric
2a40: 74 65 64 2d 61 72 65 61 73 20 22 2c 22 29 20 22 ted-areas ",") "
2a50: 2e 2a 7c 2e 2a 22 29 20 22 2e 2a 22 29 29 0a 20 .*|.*") ".*")).
2a60: 20 20 20 20 20 20 20 20 20 20 09 20 20 20 28 74 . (t
2a70: 61 72 67 65 74 2d 70 61 74 68 20 28 69 66 20 28 arget-path (if (
2a80: 6e 75 6c 6c 3f 20 28 63 64 72 20 72 65 73 6f 6c null? (cdr resol
2a90: 76 65 64 2d 70 61 74 68 29 29 20 0a 20 20 20 20 ved-path)) .
2aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ac0: 20 62 61 73 65 2d 70 61 74 68 20 0a 20 20 20 20 base-path .
2ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2af0: 20 28 63 6f 6e 63 20 62 61 73 65 2d 70 61 74 68 (conc base-path
2b00: 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 6a 6f 69 "/" (string-joi
2b10: 6e 20 28 63 64 72 20 72 65 73 6f 6c 76 65 64 2d n (cdr resolved-
2b20: 70 61 74 68 29 20 22 2f 22 29 29 29 29 29 0a 20 path) "/"))))).
2b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b40: 20 20 20 0a 09 20 20 20 20 20 20 20 20 20 20 20 ..
2b50: 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .
2b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2b70: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 65 71 if (and (not (eq
2b80: 75 61 6c 3f 20 72 65 73 74 72 69 63 74 65 64 2d ual? restricted-
2b90: 61 72 65 61 73 20 22 22 20 29 29 0a 20 20 20 20 areas "" )).
2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bb0: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
2bc0: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 20 -match (regexp
2bd0: 72 65 73 74 72 69 63 74 69 6f 6e 73 29 20 74 61 restrictions) ta
2be0: 72 67 65 74 2d 70 61 74 68 29 29 20 0a 20 20 20 rget-path)) .
2bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c00: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 (sa
2c30: 75 74 68 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 uth:print-error
2c40: 28 63 6f 6e 63 20 22 41 63 63 65 73 73 20 64 65 (conc "Access de
2c50: 6e 69 65 64 20 74 6f 20 22 20 28 73 74 72 69 6e nied to " (strin
2c60: 67 2d 6a 6f 69 6e 20 72 65 73 6f 6c 76 65 64 2d g-join resolved-
2c70: 70 61 74 68 20 22 2f 22 29 29 29 0a 20 20 20 20 path "/"))).
2c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c90: 20 20 20 20 20 20 20 20 20 20 3b 28 65 78 69 74 ;(exit
2ca0: 20 31 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 1) .
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cc0: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
2cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ce0: 20 20 20 20 74 61 72 67 65 74 2d 70 61 74 68 29 target-path)
2cf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 29 29 .))
2d10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 . #f
2d20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 61 )))..(define (sa
2d30: 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 73 68 65 6c 6c uth-common:shell
2d40: 2d 6c 73 2d 63 6d 64 20 62 61 73 65 2d 70 61 74 -ls-cmd base-pat
2d50: 68 2d 6c 69 73 74 20 65 78 74 2d 70 61 74 68 20 h-list ext-path
2d60: 74 6f 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 top-areas base-p
2d70: 61 74 68 20 74 61 69 6c 2d 63 6d 64 2d 6c 69 73 ath tail-cmd-lis
2d80: 74 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 t). (if (and
2d90: 28 6e 75 6c 6c 3f 20 62 61 73 65 2d 70 61 74 68 (null? base-path
2da0: 2d 6c 69 73 74 29 20 28 65 71 75 61 6c 3f 20 65 -list) (equal? e
2db0: 78 74 2d 70 61 74 68 20 22 22 29 20 29 0a 20 20 xt-path "") ).
2dc0: 20 20 20 20 28 70 72 69 6e 74 20 28 73 74 72 69 (print (stri
2dd0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 74 ng-intersperse t
2de0: 6f 70 2d 61 72 65 61 73 20 22 20 22 29 29 0a 20 op-areas " ")).
2df0: 20 28 6c 65 74 2a 20 28 28 72 65 73 6f 6c 76 65 (let* ((resolve
2e00: 64 2d 70 61 74 68 20 28 73 61 75 74 68 2d 63 6f d-path (sauth-co
2e10: 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 2d 70 61 74 mmon:resolve-pat
2e20: 68 20 65 78 74 2d 70 61 74 68 20 62 61 73 65 2d h ext-path base-
2e30: 70 61 74 68 2d 6c 69 73 74 20 74 6f 70 2d 61 72 path-list top-ar
2e40: 65 61 73 20 29 29 29 0a 20 20 20 20 20 20 20 20 eas ))).
2e50: 20 20 20 3b 28 70 72 69 6e 74 20 72 65 73 6f 6c ;(print resol
2e60: 76 65 64 2d 70 61 74 68 29 0a 20 20 20 20 20 20 ved-path).
2e70: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
2e80: 71 75 61 6c 3f 20 72 65 73 6f 6c 76 65 64 2d 70 qual? resolved-p
2e90: 61 74 68 20 23 66 29 29 0a 20 20 20 20 20 20 20 ath #f)).
2ea0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 (if (null? r
2eb0: 65 73 6f 6c 76 65 64 2d 70 61 74 68 29 20 0a 20 esolved-path) .
2ec0: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
2ed0: 6e 74 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 nt (string-inter
2ee0: 73 70 65 72 73 65 20 74 6f 70 2d 61 72 65 61 73 sperse top-areas
2ef0: 20 22 20 22 29 29 0a 20 20 20 20 20 20 20 20 20 " ")).
2f00: 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 (let* ((target
2f10: 2d 70 61 74 68 20 28 73 61 75 74 68 2d 63 6f 6d -path (sauth-com
2f20: 6d 6f 6e 3a 67 65 74 2d 74 61 72 67 65 74 2d 70 mon:get-target-p
2f30: 61 74 68 20 20 62 61 73 65 2d 70 61 74 68 2d 6c ath base-path-l
2f40: 69 73 74 20 20 65 78 74 2d 70 61 74 68 20 74 6f ist ext-path to
2f50: 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 61 74 p-areas base-pat
2f60: 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 h))).
2f70: 20 20 20 20 20 28 70 72 69 6e 74 20 74 61 72 67 (print targ
2f80: 65 74 2d 70 61 74 68 29 0a 20 20 20 20 20 20 20 et-path).
2f90: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
2fa0: 74 20 28 65 71 75 61 6c 3f 20 74 61 72 67 65 74 t (equal? target
2fb0: 2d 70 61 74 68 20 23 66 29 29 0a 20 20 20 20 20 -path #f)).
2fc0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
2fd0: 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
2fe0: 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 28 28 6e (cond... ((n
2ff0: 75 6c 6c 3f 20 74 61 69 6c 2d 63 6d 64 2d 6c 69 ull? tail-cmd-li
3000: 73 74 29 0a 09 09 20 20 20 20 20 28 72 75 6e 20 st)... (run
3010: 28 70 69 70 65 0a 20 20 20 20 20 20 09 20 20 20 (pipe. .
3020: 20 20 20 09 20 20 20 20 20 20 28 6c 73 20 22 2d . (ls "-
3030: 6c 72 74 22 20 2c 74 61 72 67 65 74 2d 70 61 74 lrt" ,target-pat
3040: 68 29 29 29 29 0a 09 09 20 20 28 28 6e 6f 74 20 h))))... ((not
3050: 28 65 71 75 61 6c 3f 20 28 63 61 72 20 74 61 69 (equal? (car tai
3060: 6c 2d 63 6d 64 2d 6c 69 73 74 29 20 22 7c 22 29 l-cmd-list) "|")
3070: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3080: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
3090: 74 20 22 6c 73 20 63 6d 64 20 63 61 6e 6e 6f 74 t "ls cmd cannot
30a0: 20 61 63 63 65 70 74 20 22 20 28 73 74 72 69 6e accept " (strin
30b0: 67 2d 6a 6f 69 6e 20 74 61 69 6c 2d 63 6d 64 2d g-join tail-cmd-
30c0: 6c 69 73 74 29 20 22 20 61 73 20 61 6e 20 61 72 list) " as an ar
30d0: 67 75 6d 65 6e 74 21 21 22 29 29 0a 20 20 20 20 gument!!")).
30e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
30f0: 6c 73 65 20 20 0a 20 20 20 20 20 20 20 20 20 20 lse .
3100: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 20 28 (run (
3110: 70 69 70 65 0a 20 20 20 20 20 20 09 20 20 20 20 pipe. .
3120: 20 20 09 20 20 20 20 20 20 28 6c 73 20 22 2d 6c . (ls "-l
3130: 72 74 22 20 2c 74 61 72 67 65 74 2d 70 61 74 68 rt" ,target-path
3140: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3150: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 (begin (
3160: 73 79 73 74 65 6d 20 28 73 74 72 69 6e 67 2d 6a system (string-j
3170: 6f 69 6e 20 28 63 64 72 20 74 61 69 6c 2d 63 6d oin (cdr tail-cm
3180: 64 2d 6c 69 73 74 29 29 29 29 29 29 29 29 29 29 d-list))))))))))
3190: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
31a0: 28 73 61 75 74 68 3a 70 72 69 6e 74 2d 65 72 72 (sauth:print-err
31b0: 6f 72 20 6d 73 67 29 0a 20 20 28 77 69 74 68 2d or msg). (with-
31c0: 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 output-to-port (
31d0: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
31e0: 72 74 29 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a rt)..(lambda ().
31f0: 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 28 . (print (
3200: 63 6f 6e 63 20 22 45 52 52 4f 52 3a 20 22 20 6d conc "ERROR: " m
3210: 73 67 29 29 29 29 29 0a 0a sg)))))..