Artifact
b29dfd627c44ee4ddc86b06785f08539f1ed83af:
0000: 0a 3b 3b 20 43 72 65 61 74 65 20 74 68 65 20 73 .;; Create the s
0010: 71 6c 69 74 65 20 64 62 0a 28 64 65 66 69 6e 65 qlite db.(define
0020: 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d (sauthorize:db-
0030: 64 6f 20 70 72 6f 63 29 20 0a 20 20 20 20 20 20 do proc) .
0040: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 2a 64 62 (if (or (not *db
0050: 2d 70 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 -path*).
0060: 20 20 20 20 20 20 28 6e 6f 74 20 28 66 69 6c 65 (not (file
0070: 2d 65 78 69 73 74 73 3f 20 2a 64 62 2d 70 61 74 -exists? *db-pat
0080: 68 2a 29 29 29 20 0a 09 28 62 65 67 69 6e 0a 09 h*))) ..(begin..
0090: 20 20 28 70 72 69 6e 74 20 30 20 22 5b 64 61 74 (print 0 "[dat
00a0: 61 62 61 73 65 5d 5c 6e 6c 6f 63 61 74 69 6f 6e abase]\nlocation
00b0: 20 22 20 2a 64 62 2d 70 61 74 68 2a 20 22 20 5c " *db-path* " \
00c0: 6e 5c 6e 20 49 73 20 6d 69 73 73 69 6e 67 20 66 n\n Is missing f
00d0: 72 6f 6d 20 74 68 65 20 63 6f 6e 66 69 67 20 66 rom the config f
00e0: 69 6c 65 21 22 29 0a 09 20 20 28 65 78 69 74 20 ile!").. (exit
00f0: 31 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 1))). (if (an
0100: 64 20 2a 64 62 2d 70 61 74 68 2a 0a 09 20 20 20 d *db-path*..
0110: 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 2a 64 (directory? *d
0120: 62 2d 70 61 74 68 2a 29 0a 09 20 20 20 20 20 28 b-path*).. (
0130: 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 file-read-access
0140: 3f 20 2a 64 62 2d 70 61 74 68 2a 29 29 0a 09 28 ? *db-path*))..(
0150: 6c 65 74 2a 20 28 28 64 62 70 61 74 68 20 20 20 let* ((dbpath
0160: 20 28 63 6f 6e 63 20 2a 64 62 2d 70 61 74 68 2a (conc *db-path*
0170: 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 2e 64 62 "/sauthorize.db
0180: 22 29 29 0a 09 20 20 20 20 20 20 20 28 77 72 69 ")).. (wri
0190: 74 65 61 62 6c 65 20 28 66 69 6c 65 2d 77 72 69 teable (file-wri
01a0: 74 65 2d 61 63 63 65 73 73 3f 20 64 62 70 61 74 te-access? dbpat
01b0: 68 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 65 h)).. (dbe
01c0: 78 69 73 74 73 20 20 28 66 69 6c 65 2d 65 78 69 xists (file-exi
01d0: 73 74 73 3f 20 64 62 70 61 74 68 29 29 29 0a 09 sts? dbpath)))..
01e0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
01f0: 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 ions.. exn..
0200: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 64 (begin.. (d
0210: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 45 52 ebug:print 2 "ER
0220: 52 4f 52 3a 20 70 72 6f 62 6c 65 6d 20 61 63 63 ROR: problem acc
0230: 65 73 73 69 6e 67 20 64 62 20 22 20 64 62 70 61 essing db " dbpa
0240: 74 68 0a 09 09 09 20 20 28 28 63 6f 6e 64 69 74 th.... ((condit
0250: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
0260: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
0270: 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 age) exn))..
0280: 20 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 20 (exit 1)).
0290: 20 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 20 ;(print
02a0: 22 63 61 6c 6c 69 6e 67 20 70 72 6f 63 20 22 20 "calling proc "
02b0: 70 72 6f 63 20 22 64 62 20 70 61 74 68 20 22 20 proc "db path "
02c0: 64 62 70 61 74 68 20 29 0a 09 20 20 20 28 63 61 dbpath ).. (ca
02d0: 6c 6c 2d 77 69 74 68 2d 64 61 74 61 62 61 73 65 ll-with-database
02e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 64 62 70 . dbp
02f0: 61 74 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ath.. (lambda
0300: 20 28 64 62 29 0a 09 20 20 20 20 20 20 20 3b 28 (db).. ;(
0310: 70 72 69 6e 74 20 30 20 22 63 61 6c 6c 69 6e 67 print 0 "calling
0320: 20 70 72 6f 63 20 22 20 70 72 6f 63 20 22 20 6f proc " proc " o
0330: 6e 20 64 62 20 22 20 64 62 29 0a 09 20 20 20 20 n db " db)..
0340: 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 (set-busy-hand
0350: 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 69 ler! db (busy-ti
0360: 6d 65 6f 75 74 20 31 30 30 30 30 29 29 20 3b 3b meout 10000)) ;;
0370: 20 31 30 20 73 65 63 20 74 69 6d 65 6f 75 74 0a 10 sec timeout.
0380: 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
0390: 64 62 65 78 69 73 74 73 29 28 73 61 75 74 68 6f dbexists)(sautho
03a0: 72 69 7a 65 3a 69 6e 69 74 69 61 6c 69 7a 65 2d rize:initialize-
03b0: 64 62 20 64 62 29 29 0a 09 20 20 20 20 20 20 28 db db)).. (
03c0: 70 72 6f 63 20 64 62 29 29 29 29 29 0a 09 28 70 proc db)))))..(p
03d0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 69 rint 0 "ERROR: i
03e0: 6e 76 61 6c 69 64 20 70 61 74 68 20 66 6f 72 20 nvalid path for
03f0: 73 74 6f 72 69 6e 67 20 64 61 74 61 62 61 73 65 storing database
0400: 3a 20 22 20 2a 64 62 2d 70 61 74 68 2a 29 29 29 : " *db-path*)))
0410: 0a 0a 3b 3b 65 78 65 63 75 74 65 20 61 20 71 75 ..;;execute a qu
0420: 65 72 79 0a 28 64 65 66 69 6e 65 20 28 73 61 75 ery.(define (sau
0430: 74 68 6f 72 69 7a 65 3a 64 62 2d 71 72 79 20 64 thorize:db-qry d
0440: 62 20 71 72 79 29 0a 20 20 3b 28 70 72 69 6e 74 b qry). ;(print
0450: 20 71 72 79 29 0a 20 20 28 65 78 65 63 20 28 73 qry). (exec (s
0460: 71 6c 20 64 62 20 20 71 72 79 29 29 29 0a 0a 0a ql db qry)))...
0470: 28 64 65 66 69 6e 65 20 28 73 61 75 74 68 6f 72 (define (sauthor
0480: 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e ize:do-as-callin
0490: 67 2d 75 73 65 72 20 70 72 6f 63 29 0a 20 20 28 g-user proc). (
04a0: 6c 65 74 20 28 28 65 69 64 20 28 63 75 72 72 65 let ((eid (curre
04b0: 6e 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 65 nt-effective-use
04c0: 72 2d 69 64 29 29 0a 20 20 20 20 20 20 20 20 28 r-id)). (
04d0: 63 69 64 20 28 63 75 72 72 65 6e 74 2d 75 73 65 cid (current-use
04e0: 72 2d 69 64 29 29 29 0a 20 20 20 20 28 69 66 20 r-id))). (if
04f0: 28 6e 6f 74 20 28 65 71 3f 20 65 69 64 20 63 69 (not (eq? eid ci
0500: 64 29 29 20 3b 3b 20 72 75 6e 6e 69 6e 67 20 73 d)) ;; running s
0510: 75 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 uid.
0520: 28 73 65 74 21 20 28 63 75 72 72 65 6e 74 2d 65 (set! (current-e
0530: 66 66 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 ffective-user-id
0540: 29 20 63 69 64 29 29 0a 20 20 20 20 20 3b 28 70 ) cid)). ;(p
0550: 72 69 6e 74 20 30 20 22 63 69 64 20 22 20 63 69 rint 0 "cid " ci
0560: 64 20 22 20 65 69 64 3a 22 20 65 69 64 29 0a 20 d " eid:" eid).
0570: 20 20 20 28 70 72 6f 63 29 0a 20 20 20 20 28 69 (proc). (i
0580: 66 20 28 6e 6f 74 20 28 65 71 3f 20 65 69 64 20 f (not (eq? eid
0590: 63 69 64 29 29 0a 20 20 20 20 20 20 20 20 28 73 cid)). (s
05a0: 65 74 21 20 28 63 75 72 72 65 6e 74 2d 65 66 66 et! (current-eff
05b0: 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 29 20 ective-user-id)
05c0: 65 69 64 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e eid))))...(defin
05d0: 65 20 28 72 75 6e 2d 63 6d 64 20 63 6d 64 20 61 e (run-cmd cmd a
05e0: 72 67 2d 6c 69 73 74 29 0a 20 20 3b 20 28 70 72 rg-list). ; (pr
05f0: 69 6e 74 20 28 63 75 72 72 65 6e 74 2d 65 66 66 int (current-eff
0600: 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 29 29 ective-user-id))
0610: 0a 20 20 20 3b 28 68 61 6e 64 6c 65 2d 65 78 63 . ;(handle-exc
0620: 65 70 74 69 6f 6e 73 0a 3b 09 20 20 20 20 20 65 eptions.;. e
0630: 78 6e 0a 3b 09 20 20 20 20 20 28 70 72 69 6e 74 xn.;. (print
0640: 20 30 20 22 45 52 52 4f 52 3a 20 66 61 69 6c 65 0 "ERROR: faile
0650: 64 20 74 6f 20 72 75 6e 20 73 63 72 69 70 74 20 d to run script
0660: 22 20 63 6d 64 20 22 20 77 69 74 68 20 70 61 72 " cmd " with par
0670: 61 6d 73 20 22 20 61 72 67 2d 6c 69 73 74 20 22 ams " arg-list "
0680: 20 22 20 28 65 78 6e 20 61 73 73 65 72 74 29 29 " (exn assert))
0690: 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 70 69 .. (let ((pi
06a0: 64 20 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 d (process-run c
06b0: 6d 64 20 61 72 67 2d 6c 69 73 74 29 29 29 0a 09 md arg-list)))..
06c0: 20 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d (process-
06d0: 77 61 69 74 20 70 69 64 29 29 0a 29 0a 3b 29 0a wait pid)).).;).
06e0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 65 67 73 74 ..(define (regst
06f0: 65 72 2d 6c 6f 67 20 69 6e 6c 20 75 73 72 2d 69 er-log inl usr-i
0700: 64 20 20 61 72 65 61 2d 69 64 20 20 63 6d 64 29 d area-id cmd)
0710: 0a 20 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e . (sauth-common
0720: 3a 73 68 65 6c 6c 2d 64 6f 2d 61 73 2d 61 64 6d :shell-do-as-adm
0730: 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 . (lambda
0740: 20 28 29 0a 20 20 20 20 20 20 20 20 20 28 73 61 (). (sa
0750: 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 uthorize:db-do
0760: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
0770: 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 (saut
0780: 68 6f 72 69 7a 65 3a 64 62 2d 71 72 79 20 64 62 horize:db-qry db
0790: 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 49 (conc "INSERT I
07a0: 4e 54 4f 20 61 63 74 69 6f 6e 73 20 28 63 6d 64 NTO actions (cmd
07b0: 2c 75 73 65 72 5f 69 64 2c 61 72 65 61 5f 69 64 ,user_id,area_id
07c0: 2c 61 63 74 69 6f 6e 5f 74 79 70 65 20 29 20 56 ,action_type ) V
07d0: 41 4c 55 45 53 20 28 27 73 72 65 74 72 69 65 76 ALUES ('sretriev
07e0: 65 20 22 20 69 6e 6c 20 22 27 2c 22 20 75 73 72 e " inl "'," usr
07f0: 2d 69 64 20 22 2c 22 20 20 61 72 65 61 2d 69 64 -id "," area-id
0800: 20 22 2c 20 27 63 61 74 27 20 29 22 29 29 29 29 ", 'cat' )"))))
0810: 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b )))..;;;;;;;;;;;
0820: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0830: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0840: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0850: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b ;;;;;;;;;;;;;;.;
0860: 20 43 68 65 63 6b 20 75 73 65 72 20 74 79 70 65 Check user type
0870: 73 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b s.;;;;;;;;;;;;;;
0880: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0890: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
08a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
08b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 0a 0a 3b ;;;;;;;;;;;....;
08c0: 3b 63 68 65 63 6b 20 69 66 20 61 20 75 73 65 72 ;check if a user
08d0: 20 69 73 20 61 6e 20 61 64 6d 69 6e 0a 28 64 65 is an admin.(de
08e0: 66 69 6e 65 20 28 69 73 2d 61 64 6d 69 6e 20 75 fine (is-admin u
08f0: 73 65 72 6e 61 6d 65 29 0a 20 20 20 28 6c 65 74 sername). (let
0900: 2a 20 28 28 61 64 6d 69 6e 20 23 66 29 29 0a 20 * ((admin #f)).
0910: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
0920: 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 b-do (lambda (d
0930: 62 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a b). (let*
0940: 20 28 28 64 61 74 61 2d 72 6f 77 20 28 71 75 65 ((data-row (que
0950: 72 79 20 66 65 74 63 68 20 28 73 71 6c 20 64 62 ry fetch (sql db
0960: 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 75 (conc "SELECT u
0970: 73 65 72 73 2e 69 73 5f 61 64 6d 69 6e 20 46 52 sers.is_admin FR
0980: 4f 4d 20 20 75 73 65 72 73 20 77 68 65 72 65 20 OM users where
0990: 75 73 65 72 73 2e 75 73 65 72 6e 61 6d 65 20 3d users.username =
09a0: 20 27 22 20 75 73 65 72 6e 61 6d 65 20 22 27 22 '" username "'"
09b0: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 ))))). (i
09c0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 64 61 f (not (null? da
09d0: 74 61 2d 72 6f 77 29 29 0a 20 20 20 20 20 20 20 ta-row)).
09e0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 6f 6c (let ((col
09f0: 20 20 28 63 61 72 20 64 61 74 61 2d 72 6f 77 29 (car data-row)
0a00: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0a10: 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f 6c 20 (if (equal? col
0a20: 22 79 65 73 22 29 0a 20 20 20 20 20 20 20 20 20 "yes").
0a30: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
0a40: 61 64 6d 69 6e 20 23 74 29 29 29 29 29 29 29 20 admin #t)))))))
0a50: 20 09 20 20 20 20 20 20 20 20 0a 61 64 6d 69 6e . .admin
0a60: 29 29 0a 0a 0a 3b 3b 63 68 65 63 6b 20 69 66 20 ))...;;check if
0a70: 61 20 75 73 65 72 20 69 73 20 61 6e 20 72 65 61 a user is an rea
0a80: 64 2d 61 64 6d 69 6e 0a 28 64 65 66 69 6e 65 20 d-admin.(define
0a90: 28 69 73 2d 72 65 61 64 2d 61 64 6d 69 6e 20 75 (is-read-admin u
0aa0: 73 65 72 6e 61 6d 65 29 0a 20 20 20 28 6c 65 74 sername). (let
0ab0: 2a 20 28 28 61 64 6d 69 6e 20 23 66 29 29 0a 20 * ((admin #f)).
0ac0: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
0ad0: 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 b-do (lambda (d
0ae0: 62 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a b). (let*
0af0: 20 28 28 64 61 74 61 2d 72 6f 77 20 28 71 75 65 ((data-row (que
0b00: 72 79 20 66 65 74 63 68 20 28 73 71 6c 20 64 62 ry fetch (sql db
0b10: 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 75 (conc "SELECT u
0b20: 73 65 72 73 2e 69 73 5f 61 64 6d 69 6e 20 46 52 sers.is_admin FR
0b30: 4f 4d 20 20 75 73 65 72 73 20 77 68 65 72 65 20 OM users where
0b40: 75 73 65 72 73 2e 75 73 65 72 6e 61 6d 65 20 3d users.username =
0b50: 20 27 22 20 75 73 65 72 6e 61 6d 65 20 22 27 22 '" username "'"
0b60: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 ))))). (i
0b70: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 64 61 f (not (null? da
0b80: 74 61 2d 72 6f 77 29 29 0a 20 20 20 20 20 20 20 ta-row)).
0b90: 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 6f 6c (let ((col
0ba0: 20 20 28 63 61 72 20 64 61 74 61 2d 72 6f 77 29 (car data-row)
0bb0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0bc0: 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f 6c 20 (if (equal? col
0bd0: 22 72 65 61 64 2d 61 64 6d 69 6e 22 29 0a 20 20 "read-admin").
0be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0bf0: 20 28 73 65 74 21 20 61 64 6d 69 6e 20 23 74 29 (set! admin #t)
0c00: 29 29 29 29 29 29 20 20 09 20 20 20 20 20 20 20 )))))) .
0c10: 20 0a 61 64 6d 69 6e 29 29 0a 0a 0a 3b 3b 63 68 .admin))...;;ch
0c20: 65 63 6b 20 69 66 20 75 73 65 72 20 68 61 73 20 eck if user has
0c30: 73 70 65 63 69 66 63 20 72 6f 6c 65 20 66 6f 72 specifc role for
0c40: 20 61 20 61 72 65 61 0a 28 64 65 66 69 6e 65 20 a area.(define
0c50: 28 69 73 2d 75 73 65 72 20 72 6f 6c 65 20 75 73 (is-user role us
0c60: 65 72 6e 61 6d 65 20 61 72 65 61 29 0a 20 20 28 ername area). (
0c70: 6c 65 74 2a 20 28 28 68 61 73 2d 61 63 63 65 73 let* ((has-acces
0c80: 73 20 23 66 29 29 0a 20 20 20 20 28 73 61 75 74 s #f)). (saut
0c90: 68 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 28 6c horize:db-do (l
0ca0: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
0cb0: 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 61 2d (let* ((data-
0cc0: 72 6f 77 20 28 71 75 65 72 79 20 66 65 74 63 68 row (query fetch
0cd0: 20 28 73 71 6c 20 64 62 20 28 63 6f 6e 63 20 22 (sql db (conc "
0ce0: 53 45 4c 45 43 54 20 20 70 65 72 6d 69 73 73 69 SELECT permissi
0cf0: 6f 6e 73 2e 61 63 63 65 73 73 5f 74 79 70 65 2c ons.access_type,
0d00: 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 65 78 70 permissions.exp
0d10: 69 72 61 74 69 6f 6e 20 46 52 4f 4d 20 20 75 73 iration FROM us
0d20: 65 72 73 20 2c 20 20 61 72 65 61 73 2c 20 70 65 ers , areas, pe
0d30: 72 6d 69 73 73 69 6f 6e 73 20 77 68 65 72 65 20 rmissions where
0d40: 70 65 72 6d 69 73 73 69 6f 6e 73 2e 75 73 65 72 permissions.user
0d50: 5f 69 64 20 3d 20 75 73 65 72 73 2e 69 64 20 61 _id = users.id a
0d60: 6e 64 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 61 nd permissions.a
0d70: 72 65 61 5f 69 64 20 3d 20 61 72 65 61 73 2e 69 rea_id = areas.i
0d80: 64 20 61 6e 64 20 75 73 65 72 73 2e 75 73 65 72 d and users.user
0d90: 6e 61 6d 65 20 3d 20 27 22 20 75 73 65 72 6e 61 name = '" userna
0da0: 6d 65 20 22 27 20 61 6e 64 20 61 72 65 61 73 2e me "' and areas.
0db0: 63 6f 64 65 20 3d 20 27 22 20 61 72 65 61 20 22 code = '" area "
0dc0: 27 22 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 '"))))).
0dd0: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
0de0: 64 61 74 61 2d 72 6f 77 29 29 0a 20 20 20 20 20 data-row)).
0df0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
0e00: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
0e10: 2a 20 28 28 61 63 63 65 73 73 2d 74 79 70 65 20 * ((access-type
0e20: 20 28 63 61 72 20 64 61 74 61 2d 72 6f 77 29 29 (car data-row))
0e30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0e40: 20 20 20 20 20 28 65 78 64 61 74 65 20 28 63 61 (exdate (ca
0e50: 64 72 20 64 61 74 61 2d 72 6f 77 29 29 29 0a 20 dr data-row))).
0e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
0e70: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 65 78 f (not (null? ex
0e80: 64 61 74 65 29 29 20 0a 20 20 20 20 20 20 20 20 date)) .
0e90: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 (begin .
0ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0eb0: 20 28 6c 65 74 20 28 28 76 61 6c 69 64 20 28 69 (let ((valid (i
0ec0: 73 2d 61 63 63 65 73 73 2d 76 61 6c 69 64 20 20 s-access-valid
0ed0: 65 78 64 61 74 65 29 29 29 0a 20 20 20 20 20 20 exdate))).
0ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 28 70 ;(p
0ef0: 72 69 6e 74 20 76 61 6c 69 64 29 20 0a 20 20 20 rint valid) .
0f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0f10: 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 if (and (equal?
0f20: 61 63 63 65 73 73 2d 74 79 70 65 20 72 6f 6c 65 access-type role
0f30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0f40: 20 20 20 20 20 20 20 20 20 20 28 65 71 75 61 6c (equal
0f50: 3f 20 76 61 6c 69 64 20 23 74 29 29 0a 20 20 20 ? valid #t)).
0f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f70: 28 73 65 74 21 20 68 61 73 2d 61 63 63 65 73 73 (set! has-access
0f80: 20 23 74 29 29 29 29 0a 20 20 20 20 20 20 20 20 #t)))).
0f90: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
0fa0: 41 63 63 65 73 73 20 65 78 70 69 72 65 64 22 29 Access expired")
0fb0: 29 29 29 29 29 29 29 0a 20 3b 28 70 72 69 6e 74 ))))))). ;(print
0fc0: 20 68 61 73 2d 61 63 63 65 73 73 29 0a 68 61 73 has-access).has
0fd0: 2d 61 63 63 65 73 73 29 29 0a 0a 28 64 65 66 69 -access))..(defi
0fe0: 6e 65 20 28 69 73 2d 61 63 63 65 73 73 2d 76 61 ne (is-access-va
0ff0: 6c 69 64 20 65 78 70 2d 73 74 72 29 0a 20 20 20 lid exp-str).
1000: 20 28 6c 65 74 2a 20 28 28 72 65 74 2d 76 61 6c (let* ((ret-val
1010: 20 23 66 20 29 0a 20 20 20 20 20 20 20 20 20 20 #f ).
1020: 20 28 64 61 74 65 2d 70 61 72 74 73 20 20 28 73 (date-parts (s
1030: 74 72 69 6e 67 2d 73 70 6c 69 74 20 65 78 70 2d tring-split exp-
1040: 73 74 72 20 22 2f 22 29 29 0a 20 20 20 20 20 20 str "/")).
1050: 20 20 20 20 20 28 79 72 20 28 73 74 72 69 6e 67 (yr (string
1060: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 72 20 64 61 ->number (car da
1070: 74 65 2d 70 61 72 74 73 29 29 29 0a 20 20 20 20 te-parts))).
1080: 20 20 20 20 20 20 20 28 6d 6f 6e 74 68 20 28 73 (month (s
1090: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 28 63 61 tring->number(ca
10a0: 72 20 28 63 64 72 20 64 61 74 65 2d 70 61 72 74 r (cdr date-part
10b0: 73 29 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 s)))) .
10c0: 20 20 28 64 61 79 20 28 73 74 72 69 6e 67 2d 3e (day (string->
10d0: 6e 75 6d 62 65 72 28 63 61 64 64 72 20 64 61 74 number(caddr dat
10e0: 65 2d 70 61 72 74 73 29 29 29 0a 20 20 20 20 20 e-parts))).
10f0: 20 20 20 20 20 20 28 65 78 70 2d 64 61 74 65 20 (exp-date
1100: 28 6d 61 6b 65 2d 64 61 74 65 20 30 20 30 20 30 (make-date 0 0 0
1110: 20 30 20 64 61 79 20 6d 6f 6e 74 68 20 79 72 20 0 day month yr
1120: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
1130: 20 3b 28 70 72 69 6e 74 20 20 65 78 70 2d 64 61 ;(print exp-da
1140: 74 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 te).
1150: 20 3b 28 70 72 69 6e 74 20 28 63 75 72 72 65 6e ;(print (curren
1160: 74 2d 64 61 74 65 29 29 20 20 20 0a 20 20 20 20 t-date)) .
1170: 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 (if (> (
1180: 64 61 74 65 2d 63 6f 6d 70 61 72 65 20 65 78 70 date-compare exp
1190: 2d 64 61 74 65 20 20 28 63 75 72 72 65 6e 74 2d -date (current-
11a0: 64 61 74 65 29 29 20 30 29 0a 20 20 20 20 20 20 date)) 0).
11b0: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 74 (set! ret
11c0: 2d 76 61 6c 20 23 74 29 29 0a 20 20 20 3b 28 70 -val #t)). ;(p
11d0: 72 69 6e 74 20 72 65 74 2d 76 61 6c 29 0a 20 20 rint ret-val).
11e0: 20 72 65 74 2d 76 61 6c 29 29 0a 0a 0a 3b 63 68 ret-val))...;ch
11f0: 65 63 6b 20 69 66 20 61 72 65 61 20 65 78 69 73 eck if area exis
1200: 74 73 0a 28 64 65 66 69 6e 65 20 28 61 72 65 61 ts.(define (area
1210: 2d 65 78 69 73 74 73 20 61 72 65 61 29 0a 20 20 -exists area).
1220: 20 28 6c 65 74 2a 20 28 28 61 72 65 61 2d 64 65 (let* ((area-de
1230: 66 69 6e 65 64 20 23 66 29 29 0a 20 20 20 20 28 fined #f)). (
1240: 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f sauthorize:db-do
1250: 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 (lambda (db).
1260: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 (let* ((d
1270: 61 74 61 2d 72 6f 77 20 28 71 75 65 72 79 20 66 ata-row (query f
1280: 65 74 63 68 20 28 73 71 6c 20 64 62 20 28 63 6f etch (sql db (co
1290: 6e 63 20 22 53 45 4c 45 43 54 20 20 69 64 20 46 nc "SELECT id F
12a0: 52 4f 4d 20 20 61 72 65 61 73 20 77 68 65 72 65 ROM areas where
12b0: 20 61 72 65 61 73 2e 63 6f 64 65 20 3d 20 27 22 areas.code = '"
12c0: 20 61 72 65 61 20 22 27 22 29 29 29 29 29 0a 20 area "'"))))).
12d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
12e0: 6f 74 20 28 6e 75 6c 6c 3f 20 64 61 74 61 2d 72 ot (null? data-r
12f0: 6f 77 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ow)).
1300: 20 20 20 20 20 20 28 73 65 74 21 20 61 72 65 61 (set! area
1310: 2d 64 65 66 69 6e 65 64 20 23 74 29 29 29 29 29 -defined #t)))))
1320: 0a 61 72 65 61 2d 64 65 66 69 6e 65 64 29 29 0a .area-defined)).
1330: 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b .;;;;;;;;;;;;;;;
1340: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1350: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1360: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1370: 0a 3b 20 47 65 74 20 52 65 63 6f 72 64 20 66 72 .; Get Record fr
1380: 6f 6d 20 64 61 74 61 62 61 73 65 0a 3b 3b 3b 3b om database.;;;;
1390: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
13a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
13b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
13c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 3b 67 65 ;;;;;;;;;;;..;ge
13d0: 74 73 20 61 72 65 61 20 69 64 20 62 79 20 63 6f ts area id by co
13e0: 64 65 20 0a 28 64 65 66 69 6e 65 20 28 67 65 74 de .(define (get
13f0: 2d 61 72 65 61 20 61 72 65 61 29 0a 20 20 20 28 -area area). (
1400: 6c 65 74 2a 20 28 28 61 72 65 61 2d 64 65 66 69 let* ((area-defi
1410: 6e 65 64 20 27 28 29 29 29 0a 20 20 20 20 28 73 ned '())). (s
1420: 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 authorize:db-do
1430: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
1440: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 (let* ((da
1450: 74 61 2d 72 6f 77 20 28 71 75 65 72 79 20 66 65 ta-row (query fe
1460: 74 63 68 20 28 73 71 6c 20 64 62 20 28 63 6f 6e tch (sql db (con
1470: 63 20 22 53 45 4c 45 43 54 20 20 69 64 20 46 52 c "SELECT id FR
1480: 4f 4d 20 20 61 72 65 61 73 20 77 68 65 72 65 20 OM areas where
1490: 61 72 65 61 73 2e 63 6f 64 65 20 3d 20 27 22 20 areas.code = '"
14a0: 61 72 65 61 20 22 27 22 29 29 29 29 29 0a 20 20 area "'"))))).
14b0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 20 61 (set! a
14c0: 72 65 61 2d 64 65 66 69 6e 65 64 20 64 61 74 61 rea-defined data
14d0: 2d 72 6f 77 29 29 29 29 0a 61 72 65 61 2d 64 65 -row)))).area-de
14e0: 66 69 6e 65 64 29 29 0a 0a 3b 67 65 74 20 69 64 fined))..;get id
14f0: 20 6f 66 20 75 73 65 72 73 20 74 61 62 6c 65 20 of users table
1500: 62 79 20 75 73 65 72 20 6e 61 6d 65 20 0a 28 64 by user name .(d
1510: 65 66 69 6e 65 20 28 67 65 74 2d 75 73 65 72 20 efine (get-user
1520: 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 user). (let* ((
1530: 75 73 65 72 2d 64 65 66 69 6e 65 64 20 27 28 29 user-defined '()
1540: 29 29 0a 20 20 20 20 28 73 61 75 74 68 6f 72 69 )). (sauthori
1550: 7a 65 3a 64 62 2d 64 6f 20 20 28 6c 61 6d 62 64 ze:db-do (lambd
1560: 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 20 28 a (db). (
1570: 6c 65 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 let* ((data-row
1580: 28 71 75 65 72 79 20 66 65 74 63 68 20 28 73 71 (query fetch (sq
1590: 6c 20 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 l db (conc "SELE
15a0: 43 54 20 20 69 64 20 46 52 4f 4d 20 20 75 73 65 CT id FROM use
15b0: 72 73 20 77 68 65 72 65 20 75 73 65 72 73 2e 75 rs where users.u
15c0: 73 65 72 6e 61 6d 65 20 3d 20 27 22 20 75 73 65 sername = '" use
15d0: 72 20 22 27 22 29 29 29 29 29 0a 20 20 20 20 20 r "'"))))).
15e0: 20 20 20 20 20 28 73 65 74 21 20 20 75 73 65 72 (set! user
15f0: 2d 64 65 66 69 6e 65 64 20 64 61 74 61 2d 72 6f -defined data-ro
1600: 77 29 29 29 29 0a 75 73 65 72 2d 64 65 66 69 6e w)))).user-defin
1610: 65 64 29 29 0a 0a 3b 67 65 74 20 70 65 72 6d 69 ed))..;get permi
1620: 73 73 69 6f 6e 73 20 69 64 20 62 79 20 75 73 65 ssions id by use
1630: 72 69 64 20 61 6e 64 20 61 72 65 61 20 69 64 20 rid and area id
1640: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 70 65 .(define (get-pe
1650: 72 6d 20 75 73 65 72 69 64 20 61 72 65 61 69 64 rm userid areaid
1660: 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 73 65 72 ). (let* ((user
1670: 2d 64 65 66 69 6e 65 64 20 27 28 29 29 29 0a 20 -defined '())).
1680: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
1690: 62 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 b-do (lambda (d
16a0: 62 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 b). (le
16b0: 74 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 28 71 t* ((data-row (q
16c0: 75 65 72 79 20 66 65 74 63 68 20 28 73 71 6c 20 uery fetch (sql
16d0: 64 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 db (conc "SELECT
16e0: 20 20 69 64 20 46 52 4f 4d 20 20 70 65 72 6d 69 id FROM permi
16f0: 73 73 69 6f 6e 73 20 77 68 65 72 65 20 75 73 65 ssions where use
1700: 72 5f 69 64 20 3d 20 22 20 75 73 65 72 69 64 20 r_id = " userid
1710: 22 20 61 6e 64 20 61 72 65 61 5f 69 64 20 3d 20 " and area_id =
1720: 22 20 61 72 65 61 69 64 29 29 29 29 29 0a 20 20 " areaid))))).
1730: 20 20 20 20 20 20 20 28 73 65 74 21 20 20 75 73 (set! us
1740: 65 72 2d 64 65 66 69 6e 65 64 20 64 61 74 61 2d er-defined data-
1750: 72 6f 77 29 29 29 29 0a 0a 75 73 65 72 2d 64 65 row))))..user-de
1760: 66 69 6e 65 64 29 29 0a 0a 28 64 65 66 69 6e 65 fined))..(define
1770: 20 28 67 65 74 2d 72 65 73 74 72 69 63 74 69 6f (get-restrictio
1780: 6e 73 20 62 61 73 65 2d 70 61 74 68 20 75 73 72 ns base-path usr
1790: 29 0a 28 6c 65 74 2a 20 28 28 75 73 65 72 2d 64 ).(let* ((user-d
17a0: 65 66 69 6e 65 64 20 27 28 29 29 29 0a 20 20 20 efined '())).
17b0: 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 2d (sauthorize:db-
17c0: 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 do (lambda (db)
17d0: 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a . (let*
17e0: 20 28 28 64 61 74 61 2d 72 6f 77 20 28 71 75 65 ((data-row (que
17f0: 72 79 20 66 65 74 63 68 20 28 73 71 6c 20 64 62 ry fetch (sql db
1800: 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 20 (conc "SELECT
1810: 72 65 73 74 72 69 63 74 69 6f 6e 20 46 52 4f 4d restriction FROM
1820: 20 61 72 65 61 73 2c 20 75 73 65 72 73 2c 20 70 areas, users, p
1830: 65 72 6d 69 73 73 69 6f 6e 73 20 77 68 65 72 65 ermissions where
1840: 20 20 61 72 65 61 73 2e 69 64 20 3d 20 70 65 72 areas.id = per
1850: 6d 69 73 73 69 6f 6e 73 2e 61 72 65 61 5f 69 64 missions.area_id
1860: 20 61 6e 64 20 75 73 65 72 73 2e 69 64 20 3d 20 and users.id =
1870: 20 70 65 72 6d 69 73 73 69 6f 6e 73 2e 75 73 65 permissions.use
1880: 72 5f 69 64 20 61 6e 64 20 20 75 73 65 72 73 2e r_id and users.
1890: 75 73 65 72 6e 61 6d 65 20 3d 20 27 22 20 75 73 username = '" us
18a0: 72 20 22 27 20 61 6e 64 20 61 72 65 61 73 2e 62 r "' and areas.b
18b0: 61 73 65 70 61 74 68 20 3d 20 27 22 20 62 61 73 asepath = '" bas
18c0: 65 2d 70 61 74 68 20 22 27 22 29 29 29 29 29 0a e-path "'"))))).
18d0: 20 20 20 20 20 20 20 20 20 3b 28 70 72 69 6e 74 ;(print
18e0: 20 64 61 74 61 2d 72 6f 77 29 20 0a 20 20 20 20 data-row) .
18f0: 20 20 20 20 20 28 73 65 74 21 20 20 75 73 65 72 (set! user
1900: 2d 64 65 66 69 6e 65 64 20 64 61 74 61 2d 72 6f -defined data-ro
1910: 77 29 29 29 29 0a 20 20 20 20 3b 20 20 20 28 70 w)))). ; (p
1920: 72 69 6e 74 20 75 73 65 72 2d 64 65 66 69 6e 65 rint user-define
1930: 64 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 d). (if (null?
1940: 75 73 65 72 2d 64 65 66 69 6e 65 64 29 0a 20 20 user-defined).
1950: 20 20 20 20 22 22 0a 20 20 20 20 20 20 28 63 61 "". (ca
1960: 72 20 75 73 65 72 2d 64 65 66 69 6e 65 64 29 29 r user-defined))
1970: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 ))...(define (ge
1980: 74 2d 6f 62 6a 2d 62 79 2d 70 61 74 68 20 70 61 t-obj-by-path pa
1990: 74 68 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 6f th). (let* ((o
19a0: 62 6a 20 27 28 29 29 29 0a 20 20 20 20 28 73 61 bj '())). (sa
19b0: 75 74 68 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 uthorize:db-do
19c0: 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 (lambda (db).
19d0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 (let* ((dat
19e0: 61 2d 72 6f 77 20 28 71 75 65 72 79 20 66 65 74 a-row (query fet
19f0: 63 68 20 28 73 71 6c 20 64 62 20 28 63 6f 6e 63 ch (sql db (conc
1a00: 20 22 53 45 4c 45 43 54 20 20 63 6f 64 65 2c 65 "SELECT code,e
1a10: 78 65 5f 6e 61 6d 65 2c 20 69 64 2c 20 62 61 73 xe_name, id, bas
1a20: 65 70 61 74 68 20 46 52 4f 4d 20 20 61 72 65 61 epath FROM area
1a30: 73 20 77 68 65 72 65 20 61 72 65 61 73 2e 62 61 s where areas.ba
1a40: 73 65 70 61 74 68 20 3d 20 27 22 20 70 61 74 68 sepath = '" path
1a50: 20 22 27 22 29 29 29 29 29 0a 20 20 20 20 20 20 "'"))))).
1a60: 20 20 20 28 73 65 74 21 20 20 6f 62 6a 20 64 61 (set! obj da
1a70: 74 61 2d 72 6f 77 29 29 29 29 0a 6f 62 6a 29 29 ta-row)))).obj))
1a80: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6f ..(define (get-o
1a90: 62 6a 2d 62 79 2d 63 6f 64 65 20 63 6f 64 65 20 bj-by-code code
1aa0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6f 62 6a 20 ). (let* ((obj
1ab0: 27 28 29 29 29 0a 20 20 20 20 28 73 61 75 74 68 '())). (sauth
1ac0: 6f 72 69 7a 65 3a 64 62 2d 64 6f 20 20 28 6c 61 orize:db-do (la
1ad0: 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 mbda (db).
1ae0: 20 20 3b 28 70 72 69 6e 74 20 28 63 6f 6e 63 20 ;(print (conc
1af0: 22 53 45 4c 45 43 54 20 20 63 6f 64 65 2c 20 65 "SELECT code, e
1b00: 78 65 5f 6e 61 6d 65 2c 20 20 69 64 2c 20 62 61 xe_name, id, ba
1b10: 73 65 70 61 74 68 2c 20 72 65 71 75 69 72 65 64 sepath, required
1b20: 5f 67 72 70 73 20 20 46 52 4f 4d 20 20 61 72 65 _grps FROM are
1b30: 61 73 20 77 68 65 72 65 20 61 72 65 61 73 2e 63 as where areas.c
1b40: 6f 64 65 20 3d 20 27 22 20 63 6f 64 65 20 22 27 ode = '" code "'
1b50: 22 29 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 ")). (let
1b60: 2a 20 28 28 64 61 74 61 2d 72 6f 77 20 28 71 75 * ((data-row (qu
1b70: 65 72 79 20 66 65 74 63 68 20 28 73 71 6c 20 64 ery fetch (sql d
1b80: 62 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 b (conc "SELECT
1b90: 20 63 6f 64 65 2c 20 65 78 65 5f 6e 61 6d 65 2c code, exe_name,
1ba0: 20 20 69 64 2c 20 62 61 73 65 70 61 74 68 2c 20 id, basepath,
1bb0: 72 65 71 75 69 72 65 64 5f 67 72 70 73 20 20 46 required_grps F
1bc0: 52 4f 4d 20 20 61 72 65 61 73 20 77 68 65 72 65 ROM areas where
1bd0: 20 61 72 65 61 73 2e 63 6f 64 65 20 3d 20 27 22 areas.code = '"
1be0: 20 63 6f 64 65 20 22 27 22 29 29 29 29 29 0a 20 code "'"))))).
1bf0: 20 20 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 ;(print
1c00: 64 61 74 61 2d 72 6f 77 29 0a 20 20 20 20 20 20 data-row).
1c10: 20 20 20 28 73 65 74 21 20 20 6f 62 6a 20 64 61 (set! obj da
1c20: 74 61 2d 72 6f 77 29 0a 20 20 20 20 20 20 20 20 ta-row).
1c30: 20 3b 28 70 72 69 6e 74 20 6f 62 6a 29 20 0a 20 ;(print obj) .
1c40: 20 20 20 20 20 20 20 29 29 29 0a 20 20 20 20 28 ))). (
1c50: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6f if (not (null? o
1c60: 62 6a 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 bj)). (
1c70: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
1c80: 28 6c 65 74 2a 20 28 28 72 65 71 2d 67 72 70 20 (let* ((req-grp
1c90: 28 63 61 64 64 72 20 28 63 64 64 72 20 6f 62 6a (caddr (cddr obj
1ca0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
1cb0: 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 6f 2d (sauthorize:do-
1cc0: 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a as-calling-user.
1cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
1ce0: 6d 62 64 61 20 28 29 0a 20 28 73 61 75 74 68 2d mbda (). (sauth-
1cf0: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 75 73 65 common:check-use
1d00: 72 2d 67 72 6f 75 70 73 20 72 65 71 2d 67 72 70 r-groups req-grp
1d10: 29 29 29 29 29 29 0a 6f 62 6a 29 29 0a 0a 28 64 )))))).obj))..(d
1d20: 65 66 69 6e 65 20 28 73 61 75 74 68 2d 63 6f 6d efine (sauth-com
1d30: 6d 6f 6e 3a 63 68 65 63 6b 2d 75 73 65 72 2d 67 mon:check-user-g
1d40: 72 6f 75 70 73 20 72 65 71 2d 67 72 70 29 0a 28 roups req-grp).(
1d50: 6c 65 74 2a 20 28 28 63 75 72 72 65 6e 74 2d 67 let* ((current-g
1d60: 72 6f 75 70 73 20 20 28 67 65 74 2d 67 72 6f 75 roups (get-grou
1d70: 70 73 29 20 29 0a 20 20 20 20 20 20 20 20 28 72 ps) ). (r
1d80: 65 71 2d 67 72 70 2d 6c 69 73 74 20 28 73 74 72 eq-grp-list (str
1d90: 69 6e 67 2d 73 70 6c 69 74 20 72 65 71 2d 67 72 ing-split req-gr
1da0: 70 20 22 2c 22 29 29 29 0a 20 20 20 20 20 20 20 p ","))).
1db0: 20 3b 28 70 72 69 6e 74 20 72 65 71 2d 67 72 70 ;(print req-grp
1dc0: 2d 6c 69 73 74 29 0a 20 20 20 20 20 20 20 20 28 -list). (
1dd0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
1de0: 20 28 67 72 70 29 0a 09 20 20 28 6c 65 74 20 28 (grp).. (let (
1df0: 28 67 72 70 2d 69 6e 66 6f 20 28 67 72 6f 75 70 (grp-info (group
1e00: 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 67 72 70 -information grp
1e10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
1e20: 20 20 20 3b 28 70 72 69 6e 74 20 67 72 70 2d 69 ;(print grp-i
1e30: 6e 66 6f 20 22 20 22 20 67 72 70 29 0a 20 20 20 nfo " " grp).
1e40: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
1e50: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 67 72 70 (not (equal? grp
1e60: 2d 69 6e 66 6f 20 23 66 29 29 0a 20 20 20 20 20 -info #f)).
1e70: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
1e80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1e90: 20 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 (if (not (memb
1ea0: 65 72 20 20 28 63 61 64 64 72 20 67 72 70 2d 69 er (caddr grp-i
1eb0: 6e 66 6f 29 20 63 75 72 72 65 6e 74 2d 67 72 6f nfo) current-gro
1ec0: 75 70 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ups)).
1ed0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a (begin .
1ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ef0: 20 20 20 20 28 73 61 75 74 68 3a 70 72 69 6e 74 (sauth:print
1f00: 2d 65 72 72 6f 72 20 28 63 6f 6e 63 20 22 50 6c -error (conc "Pl
1f10: 65 61 73 65 20 77 61 73 68 20 22 20 67 72 70 20 ease wash " grp
1f20: 22 20 67 72 6f 75 70 20 69 6e 20 79 6f 75 72 20 " group in your
1f30: 78 74 65 72 6d 21 21 20 22 20 29 29 0a 20 20 20 xterm!! " )).
1f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f50: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 29 29 (exit 1)))))))
1f60: 0a 09 20 20 20 20 20 72 65 71 2d 67 72 70 2d 6c .. req-grp-l
1f70: 69 73 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ist)))..(define
1f80: 28 67 65 74 2d 6f 62 6a 2d 62 79 2d 63 6f 64 65 (get-obj-by-code
1f90: 2d 6e 6f 2d 67 72 70 2d 76 61 6c 69 64 61 74 69 -no-grp-validati
1fa0: 6f 6e 20 63 6f 64 65 20 29 0a 20 20 28 6c 65 74 on code ). (let
1fb0: 2a 20 28 28 6f 62 6a 20 27 28 29 29 29 0a 20 20 * ((obj '())).
1fc0: 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 62 (sauthorize:db
1fd0: 2d 64 6f 20 20 28 6c 61 6d 62 64 61 20 28 64 62 -do (lambda (db
1fe0: 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ). (let*
1ff0: 28 28 64 61 74 61 2d 72 6f 77 20 28 71 75 65 72 ((data-row (quer
2000: 79 20 66 65 74 63 68 20 28 73 71 6c 20 64 62 20 y fetch (sql db
2010: 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 20 63 (conc "SELECT c
2020: 6f 64 65 2c 20 65 78 65 5f 6e 61 6d 65 2c 20 20 ode, exe_name,
2030: 69 64 2c 20 62 61 73 65 70 61 74 68 20 20 46 52 id, basepath FR
2040: 4f 4d 20 20 61 72 65 61 73 20 77 68 65 72 65 20 OM areas where
2050: 61 72 65 61 73 2e 63 6f 64 65 20 3d 20 27 22 20 areas.code = '"
2060: 63 6f 64 65 20 22 27 22 29 29 29 29 29 0a 20 20 code "'"))))).
2070: 20 20 20 20 20 20 20 28 73 65 74 21 20 20 6f 62 (set! ob
2080: 6a 20 64 61 74 61 2d 72 6f 77 29 29 29 29 0a 3b j data-row)))).;
2090: 28 70 72 69 6e 74 20 6f 62 6a 29 0a 6f 62 6a 29 (print obj).obj)
20a0: 29 0a 0a 0a 0a 0a 3b 3b 20 66 75 6e 63 74 69 6f ).....;; functio
20b0: 6e 20 74 6f 20 76 61 6c 69 64 61 74 65 20 74 68 n to validate th
20c0: 65 20 75 73 65 72 73 20 69 6e 70 75 74 20 66 6f e users input fo
20d0: 72 20 74 61 72 67 65 74 20 70 61 74 68 20 61 6e r target path an
20e0: 64 20 72 65 73 6f 6c 76 65 20 74 68 65 20 70 61 d resolve the pa
20f0: 74 68 0a 3b 3b 20 54 4f 44 4f 3a 20 43 68 65 63 th.;; TODO: Chec
2100: 6b 20 66 6f 72 20 72 65 73 74 72 69 63 74 69 6f k for restrictio
2110: 6e 20 69 6e 20 73 75 62 70 61 74 68 20 0a 28 64 n in subpath .(d
2120: 65 66 69 6e 65 20 28 73 61 75 74 68 2d 63 6f 6d efine (sauth-com
2130: 6d 6f 6e 3a 72 65 73 6f 6c 76 65 2d 70 61 74 68 mon:resolve-path
2140: 20 20 6e 65 77 20 63 75 72 72 65 6e 74 20 61 6c new current al
2150: 6c 6f 77 65 64 2d 73 68 65 65 74 73 29 0a 20 20 lowed-sheets).
2160: 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 2d (let* ((target-
2170: 70 61 74 68 20 28 61 70 70 65 6e 64 20 20 63 75 path (append cu
2180: 72 72 65 6e 74 20 28 73 74 72 69 6e 67 2d 73 70 rrent (string-sp
2190: 6c 69 74 20 6e 65 77 20 22 2f 22 29 29 29 0a 20 lit new "/"))).
21a0: 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 (target
21b0: 2d 70 61 74 68 2d 73 74 72 69 6e 67 20 28 73 74 -path-string (st
21c0: 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 65 74 ring-join target
21d0: 2d 70 61 74 68 20 22 2f 22 29 29 0a 20 20 20 20 -path "/")).
21e0: 20 20 20 20 20 20 28 6e 6f 72 6d 61 6c 2d 70 61 (normal-pa
21f0: 74 68 20 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 th (normalize-pa
2200: 74 68 6e 61 6d 65 20 74 61 72 67 65 74 2d 70 61 thname target-pa
2210: 74 68 2d 73 74 72 69 6e 67 29 29 0a 20 20 20 20 th-string)).
2220: 20 20 20 20 20 20 28 6e 6f 72 6d 61 6c 2d 6c 69 (normal-li
2230: 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 st (string-split
2240: 20 6e 6f 72 6d 61 6c 2d 70 61 74 68 20 22 2f 22 normal-path "/"
2250: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 )). (r
2260: 65 74 20 27 28 29 29 29 0a 20 20 20 28 69 66 20 et '())). (if
2270: 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 (string-contains
2280: 20 20 20 6e 6f 72 6d 61 6c 2d 70 61 74 68 20 22 normal-path "
2290: 2e 2e 22 29 0a 20 20 20 20 28 62 65 67 69 6e 0a .."). (begin.
22a0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 (print "ER
22b0: 52 4f 52 3a 20 50 61 74 68 20 20 22 20 6e 65 77 ROR: Path " new
22c0: 20 22 20 72 65 73 6f 6c 76 65 64 20 6f 75 74 73 " resolved outs
22d0: 69 64 65 20 74 61 72 67 65 74 20 61 72 65 61 20 ide target area
22e0: 22 29 0a 20 20 20 20 20 20 23 66 29 0a 20 20 20 "). #f).
22f0: 20 28 69 66 28 65 71 75 61 6c 3f 20 6e 6f 72 6d (if(equal? norm
2300: 61 6c 2d 70 61 74 68 20 22 2e 22 29 0a 20 20 20 al-path ".").
2310: 20 20 20 72 65 74 20 20 0a 20 20 20 20 28 69 66 ret . (if
2320: 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 20 28 (not (member (
2330: 63 61 72 20 6e 6f 72 6d 61 6c 2d 6c 69 73 74 29 car normal-list)
2340: 20 61 6c 6c 6f 77 65 64 2d 73 68 65 65 74 73 29 allowed-sheets)
2350: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ). (begin.
2360: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 (print "ERR
2370: 4f 52 3a 20 50 65 72 6d 69 73 69 6f 6e 20 64 65 OR: Permision de
2380: 6e 69 65 64 20 74 6f 20 20 22 20 6e 65 77 20 29 nied to " new )
2390: 0a 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 . #f).
23a0: 6e 6f 72 6d 61 6c 2d 6c 69 73 74 29 29 29 29 29 normal-list)))))
23b0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 61 75 74 68 ..(define (sauth
23c0: 2d 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 61 72 67 -common:get-targ
23d0: 65 74 2d 70 61 74 68 20 62 61 73 65 2d 70 61 74 et-path base-pat
23e0: 68 2d 6c 69 73 74 20 65 78 74 2d 70 61 74 68 20 h-list ext-path
23f0: 74 6f 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 top-areas base-p
2400: 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 ath). (let* ((r
2410: 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 28 73 61 esolved-path (sa
2420: 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c uth-common:resol
2430: 76 65 2d 70 61 74 68 20 65 78 74 2d 70 61 74 68 ve-path ext-path
2440: 20 62 61 73 65 2d 70 61 74 68 2d 6c 69 73 74 20 base-path-list
2450: 74 6f 70 2d 61 72 65 61 73 20 29 29 0a 20 20 20 top-areas )).
2460: 20 20 20 20 20 20 20 28 75 73 72 20 28 63 75 72 (usr (cur
2470: 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 rent-user-name)
2480: 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 ) ). (i
2490: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 72 f (not (equal? r
24a0: 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 23 66 29 esolved-path #f)
24b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 66 ). (if
24c0: 20 28 6e 75 6c 6c 3f 20 72 65 73 6f 6c 76 65 64 (null? resolved
24d0: 2d 70 61 74 68 29 20 0a 20 20 20 20 20 20 20 20 -path) .
24e0: 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 #f.
24f0: 20 20 20 28 6c 65 74 2a 20 28 28 73 68 65 65 74 (let* ((sheet
2500: 20 28 63 61 72 20 72 65 73 6f 6c 76 65 64 2d 70 (car resolved-p
2510: 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 ath)).
2520: 20 20 20 20 20 20 20 20 20 28 72 65 73 74 72 69 (restri
2530: 63 74 65 64 2d 61 72 65 61 73 20 28 67 65 74 2d cted-areas (get-
2540: 72 65 73 74 72 69 63 74 69 6f 6e 73 20 62 61 73 restrictions bas
2550: 65 2d 70 61 74 68 20 75 73 72 29 29 0a 20 20 20 e-path usr)).
2560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2570: 28 72 65 73 74 72 69 63 74 69 6f 6e 73 20 28 63 (restrictions (c
2580: 6f 6e 63 20 22 2e 2a 22 20 28 73 74 72 69 6e 67 onc ".*" (string
2590: 2d 6a 6f 69 6e 20 28 73 74 72 69 6e 67 2d 73 70 -join (string-sp
25a0: 6c 69 74 20 72 65 73 74 72 69 63 74 65 64 2d 61 lit restricted-a
25b0: 72 65 61 73 20 22 2c 22 29 20 22 2e 2a 7c 2e 2a reas ",") ".*|.*
25c0: 22 29 20 22 2e 2a 22 29 29 0a 20 20 20 20 20 20 ") ".*")).
25d0: 20 20 20 20 20 09 20 20 20 28 74 61 72 67 65 74 . (target
25e0: 2d 70 61 74 68 20 28 69 66 20 28 6e 75 6c 6c 3f -path (if (null?
25f0: 20 28 63 64 72 20 72 65 73 6f 6c 76 65 64 2d 70 (cdr resolved-p
2600: 61 74 68 29 29 20 0a 20 20 20 20 20 20 20 20 20 ath)) .
2610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2620: 20 20 20 20 20 20 20 20 20 20 20 20 62 61 73 65 base
2630: 2d 70 61 74 68 20 0a 20 20 20 20 20 20 20 20 20 -path .
2640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2650: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
2660: 63 20 62 61 73 65 2d 70 61 74 68 20 22 2f 22 20 c base-path "/"
2670: 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 63 64 (string-join (cd
2680: 72 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 29 r resolved-path)
2690: 20 22 2f 22 29 29 29 29 29 0a 20 20 20 20 20 20 "/"))))).
26a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 ..
26b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
26c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
26e0: 6e 64 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 nd (not (equal?
26f0: 72 65 73 74 72 69 63 74 65 64 2d 61 72 65 61 73 restricted-areas
2700: 20 22 22 20 29 29 0a 20 20 20 20 20 20 20 20 20 "" )).
2710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2720: 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 (string-matc
2730: 68 20 28 72 65 67 65 78 70 20 20 72 65 73 74 72 h (regexp restr
2740: 69 63 74 69 6f 6e 73 29 20 74 61 72 67 65 74 2d ictions) target-
2750: 70 61 74 68 29 29 20 0a 20 20 20 20 20 20 20 20 path)) .
2760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2770: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
2780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2790: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 3a 70 (sauth:p
27a0: 72 69 6e 74 2d 65 72 72 6f 72 20 22 41 63 63 65 rint-error "Acce
27b0: 73 73 20 64 65 6e 69 65 64 20 74 6f 20 22 20 28 ss denied to " (
27c0: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 72 65 73 6f string-join reso
27d0: 6c 76 65 64 2d 70 61 74 68 20 22 2f 22 29 29 0a lved-path "/")).
27e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 28 ;(
2800: 65 78 69 74 20 31 29 20 20 20 0a 20 20 20 20 20 exit 1) .
2810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2820: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f).
2830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2840: 20 20 20 20 20 20 20 20 74 61 72 67 65 74 2d 70 target-p
2850: 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 ath).
2860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2870: 20 0a 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 .)).
2880: 20 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 #f)))..(define
2890: 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 73 (sauth-common:s
28a0: 68 65 6c 6c 2d 6c 73 2d 63 6d 64 20 62 61 73 65 hell-ls-cmd base
28b0: 2d 70 61 74 68 2d 6c 69 73 74 20 65 78 74 2d 70 -path-list ext-p
28c0: 61 74 68 20 74 6f 70 2d 61 72 65 61 73 20 62 61 ath top-areas ba
28d0: 73 65 2d 70 61 74 68 20 74 61 69 6c 2d 63 6d 64 se-path tail-cmd
28e0: 2d 6c 69 73 74 29 0a 20 20 20 20 28 69 66 20 28 -list). (if (
28f0: 61 6e 64 20 28 6e 75 6c 6c 3f 20 62 61 73 65 2d and (null? base-
2900: 70 61 74 68 2d 6c 69 73 74 29 20 28 65 71 75 61 path-list) (equa
2910: 6c 3f 20 65 78 74 2d 70 61 74 68 20 22 22 29 20 l? ext-path "")
2920: 29 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 28 ). (print (
2930: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
2940: 73 65 20 74 6f 70 2d 61 72 65 61 73 20 22 20 22 se top-areas " "
2950: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 73 )). (let* ((res
2960: 6f 6c 76 65 64 2d 70 61 74 68 20 28 73 61 75 74 olved-path (saut
2970: 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 h-common:resolve
2980: 2d 70 61 74 68 20 65 78 74 2d 70 61 74 68 20 62 -path ext-path b
2990: 61 73 65 2d 70 61 74 68 2d 6c 69 73 74 20 74 6f ase-path-list to
29a0: 70 2d 61 72 65 61 73 20 29 29 29 0a 20 20 20 20 p-areas ))).
29b0: 20 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 72 ;(print r
29c0: 65 73 6f 6c 76 65 64 2d 70 61 74 68 29 0a 20 20 esolved-path).
29d0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
29e0: 74 20 28 65 71 75 61 6c 3f 20 72 65 73 6f 6c 76 t (equal? resolv
29f0: 65 64 2d 70 61 74 68 20 23 66 29 29 0a 20 20 20 ed-path #f)).
2a00: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
2a10: 6c 3f 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 l? resolved-path
2a20: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
2a30: 28 70 72 69 6e 74 20 28 73 74 72 69 6e 67 2d 69 (print (string-i
2a40: 6e 74 65 72 73 70 65 72 73 65 20 74 6f 70 2d 61 ntersperse top-a
2a50: 72 65 61 73 20 22 20 22 29 29 0a 20 20 20 20 20 reas " ")).
2a60: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 (let* ((ta
2a70: 72 67 65 74 2d 70 61 74 68 20 28 73 61 75 74 68 rget-path (sauth
2a80: 2d 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 61 72 67 -common:get-targ
2a90: 65 74 2d 70 61 74 68 20 20 62 61 73 65 2d 70 61 et-path base-pa
2aa0: 74 68 2d 6c 69 73 74 20 20 65 78 74 2d 70 61 74 th-list ext-pat
2ab0: 68 20 74 6f 70 2d 61 72 65 61 73 20 62 61 73 65 h top-areas base
2ac0: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 -path))).
2ad0: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
2ae0: 74 61 72 67 65 74 2d 70 61 74 68 29 0a 20 20 20 target-path).
2af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
2b00: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 74 61 (not (equal? ta
2b10: 72 67 65 74 2d 70 61 74 68 20 23 66 29 29 0a 20 rget-path #f)).
2b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2b30: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
2b40: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 (cond...
2b50: 20 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 2d 63 6d ((null? tail-cm
2b60: 64 2d 6c 69 73 74 29 0a 09 09 20 20 20 20 20 28 d-list)... (
2b70: 72 75 6e 20 28 70 69 70 65 0a 20 20 20 20 20 20 run (pipe.
2b80: 09 20 20 20 20 20 20 09 20 20 20 20 20 20 28 6c . . (l
2b90: 73 20 22 2d 6c 72 74 22 20 2c 74 61 72 67 65 74 s "-lrt" ,target
2ba0: 2d 70 61 74 68 29 29 29 29 0a 09 09 20 20 28 28 -path))))... ((
2bb0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 63 61 72 not (equal? (car
2bc0: 20 74 61 69 6c 2d 63 6d 64 2d 6c 69 73 74 29 20 tail-cmd-list)
2bd0: 22 7c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 "|")).
2be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2bf0: 70 72 69 6e 74 20 22 6c 73 20 63 6d 64 20 63 61 print "ls cmd ca
2c00: 6e 6e 6f 74 20 61 63 63 65 70 74 20 22 20 28 73 nnot accept " (s
2c10: 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 69 6c 2d tring-join tail-
2c20: 63 6d 64 2d 6c 69 73 74 29 20 22 20 61 73 20 61 cmd-list) " as a
2c30: 6e 20 61 72 67 75 6d 65 6e 74 21 21 22 29 29 0a n argument!!")).
2c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c50: 20 20 28 65 6c 73 65 20 20 0a 20 20 20 20 20 20 (else .
2c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
2c70: 75 6e 20 28 70 69 70 65 0a 20 20 20 20 20 20 09 un (pipe. .
2c80: 20 20 20 20 20 20 09 20 20 20 20 20 20 28 6c 73 . (ls
2c90: 20 22 2d 6c 72 74 22 20 2c 74 61 72 67 65 74 2d "-lrt" ,target-
2ca0: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 path).
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
2cc0: 69 6e 20 28 73 79 73 74 65 6d 20 28 73 74 72 69 in (system (stri
2cd0: 6e 67 2d 6a 6f 69 6e 20 28 63 64 72 20 74 61 69 ng-join (cdr tai
2ce0: 6c 2d 63 6d 64 2d 6c 69 73 74 29 29 29 29 29 29 l-cmd-list))))))
2cf0: 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ))))))))))..(def
2d00: 69 6e 65 20 28 73 61 75 74 68 3a 70 72 69 6e 74 ine (sauth:print
2d10: 2d 65 72 72 6f 72 20 6d 73 67 29 0a 20 20 28 77 -error msg). (w
2d20: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
2d30: 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f rt (current-erro
2d40: 72 2d 70 6f 72 74 29 0a 09 28 6c 61 6d 62 64 61 r-port)..(lambda
2d50: 20 28 29 0a 09 20 20 20 20 20 20 20 28 70 72 69 ().. (pri
2d60: 6e 74 20 28 63 6f 6e 63 20 22 45 52 52 4f 52 3a nt (conc "ERROR:
2d70: 20 22 20 6d 73 67 29 29 29 29 29 0a 0a " msg)))))..