Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -68,10 +68,16 @@ all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest +stest: $(OFILES) sretrieve.scm + csc $(OFILES) sretrieve.scm -o datashare-testing/sretrieve_pjhatwal + +satest: + echo $(CSCOPTS) "--" $(OFILES) "--" $(GOFILES) "--" $(MOFILES) + dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -192,10 +192,11 @@ ("-tag-expr" . x) ;; misc ("-debug" . #f) ;; for *verbosity* > 2 ("-load" . #f) ;; load and exectute a scheme file ("-log" . #f) + ("-override-user" . #f) ("-msg" . M) ("-start-dir" . S) ("-set-vars" . v) ("-config" . h) )) @@ -474,22 +475,26 @@ ;; epoch. This aligns times properly for triggers in some cases. ;; ;; extra-dat format is ( 'x xval 'y yval .... ) ;; (define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f)) - (let* ((sched (cond + (let* ((sched (cond ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time ((number? sched-in) sched-in) (else (current-seconds)))) + (user (if (and args-alist (hash-table? args-alist)) + (hash-table-ref/default args-alist "-override-user" (current-user-name)) + (current-user-name))) + (args-data (if args-alist (if (hash-table? args-alist) ;; seriously? (hash-table->alist args-alist) args-alist) (hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline (alldat (apply append (list 'A action - 'U (current-user-name) + 'U user 'D sched) (if area-path (list 'S area-path) ;; the area-path is mapped to the start-dir '()) (if (list? extra-dat) @@ -503,16 +508,17 @@ (pmeta (assoc param *arg-keys*)) ;; translate the card key to a megatest switch or parameter (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys (meta (if (or pmeta smeta) (cdr (or pmeta smeta)) ;; found it? #f))) - (if (or pmeta smeta) ;; construct the switch/param pair. + (if meta ;; construct the switch/param pair. (list meta value) '()))) + (filter cdr args-data))))) - (print "Alldat: " alldat - " args-data: " args-data) + (print "Alldat: " alldat ) ;;Do not removed. This is uesed by other applications to calculate z card + ;(exit) (add-z-card (apply construct-sdat alldat)))) (define (simple-setup start-dir-in) (let* ((start-dir (or start-dir-in ".")) @@ -1067,10 +1073,11 @@ 'T "access-denied" 'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c 't (alist-ref 't pkta))))) (write-pkt pktsdir ack-uuid ack-pkt)))))) pkts)))))) + (define (check-access user mtconf action area) ;; NOTE: Need control over defaults. E.g. default might be no access (let* ((access-ctrl (hash-table-exists? mtconf "access")) ;; if there is an access section the default is to REQUIRE enablement/access (access-list (map (lambda (x) @@ -1078,19 +1085,21 @@ (string-split (or (configf:lookup mtconf "access" area) ;; userid:rightstype userid2:rightstype2 ... (if access-ctrl "*:none" ;; nobody has access by default "*:all"))))) (access-types-dat (configf:get-section mtconf "accesstypes"))) - (debug:print 0 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area) + (debug:print 2 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area) (if access-ctrl (let* ((user-access (or (assoc user access-list) (assoc "*" access-list))) - (access-type (cadr user-access)) + (access-type (if user-access + (cadr user-access) + #f)) (access-types (let ((res (alist-ref access-type access-types-dat equal?))) (if res (car res) res))) (allowed-actions (string-split (or access-types "")))) - (print "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type) + (debug:print 2 *default-log-port* "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type) (cond ((and access-types (member action allowed-actions)) ;; (print "Access granted for " user " for " action) #t) (else @@ -1126,12 +1135,21 @@ (exit 1)) ((not area) (print "ERROR: no area specified. Use -area ") (exit 1)) (else - (let ((user (current-user-name))) - (if (check-access user mtconf *action* area);; check rights + (let* ((usr-admin (check-access (current-user-name) mtconf "override" area)) + (user (if (and usr-admin (args:get-arg "-override-user")) + (args:get-arg "-override-user") + (current-user-name)))) + ; (print "user 123 " usr-admin ) + ;(exit 1) + (if (and (not usr-admin) (args:get-arg "-override-user")) + (begin + (print user " does not have access to override user") + (exit 1))) + (if (check-access user mtconf *action* area);; check rights (print "Access granted for " *action* " action by " user) (begin (print "Access denied for " *action* " action by " user) (exit 1)))))) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -21,12 +21,12 @@ (use scsh-process) (use srfi-18) (use srfi-19) (use refdb) (use sql-de-lite srfi-1 posix regex regex-case srfi-69) -(declare (uses common)) -(declare (uses configf)) +;(declare (uses common)) +;(declare (uses configf)) (declare (uses margs)) (declare (uses megatest-version)) (include "megatest-fossil-hash.scm") @@ -34,10 +34,12 @@ (include "sauth-paths.scm") (include "sauth-common.scm") (define (toplevel-command . args) #f) (use readline) + + ;; ;; GLOBALS ;; @@ -983,10 +985,44 @@ (begin (sauthorize:do-as-calling-user (lambda () (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) + ((cat) + (if (< (length args) 2) + (begin + (sauth:print-error "Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + + (if (null? area-obj) + (begin + (sauth:print-error (conc "Area " area " does not exist")) + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) +;(sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) + + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:shell-cat-cmd (list area) sub-path top-areas base-path '())))))) ((ls) (cond ((< (length args) 1) (begin (print "ERROR: Missing arguments; ") @@ -1002,10 +1038,13 @@ (caddr (cdr area-obj))))) (if (null? area-obj) (begin (print "Area " area " does not exist") (exit 1))) + + ; (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + (sauth-common:shell-ls-cmd '() area top-areas base-path '()) (sauthorize:do-as-calling-user (lambda () (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))) ((> (length args) 1)