DELETED sauth-common.scm
Index: sauth-common.scm
==================================================================
--- sauth-common.scm
+++ /dev/null
@@ -1,328 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-
-;; Create the sqlite db
-(define (sauthorize:db-do proc)
- (if (or (not *db-path*)
- (not (file-exists? *db-path*)))
- (begin
- (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
- (exit 1)))
- (if (and *db-path*
- (directory? *db-path*)
- (file-read-access? *db-path*))
- (let* ((dbpath (conc *db-path* "/sauthorize.db"))
- (writeable (file-write-access? dbpath))
- (dbexists (file-exists? dbpath)))
- (handle-exceptions
- exn
- (begin
- (print 2 "ERROR: problem accessing db " dbpath
- ((condition-property-accessor 'exn 'message) exn))
- (exit 1))
- ;(print "calling proc " proc "db path " dbpath )
- (call-with-database
- dbpath
- (lambda (db)
- ;(print 0 "calling proc " proc " on db " db)
- (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
- (if (not dbexists)(sauthorize:initialize-db db))
- (proc db)))))
- (print 0 "ERROR: invalid path for storing database: " *db-path*)))
-
-;;execute a query
-(define (sauthorize:db-qry db qry)
- ;(print qry)
- (exec (sql db qry)))
-
-
-(define (sauthorize:do-as-calling-user proc)
- (let ((eid (current-effective-user-id))
- (cid (current-user-id)))
- (if (not (eq? eid cid)) ;; running suid
- (set! (current-effective-user-id) cid))
- ;(print 0 "cid " cid " eid:" eid)
- (proc)
- (if (not (eq? eid cid))
- (set! (current-effective-user-id) eid))))
-
-
-(define (run-cmd cmd arg-list)
- ; (print (current-effective-user-id))
- ;(handle-exceptions
-; exn
-; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
- (let ((pid (process-run cmd arg-list)))
- (process-wait pid))
-)
-;)
-
-
-(define (regster-log inl usr-id area-id cmd)
- (sauth-common:shell-do-as-adm
- (lambda ()
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )")))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; Check user types
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-;;check if a user is an admin
-(define (is-admin username)
- (let* ((admin #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
- (if (not (null? data-row))
- (let ((col (car data-row)))
- (if (equal? col "yes")
- (set! admin #t)))))))
-admin))
-
-
-;;check if a user is an read-admin
-(define (is-read-admin username)
- (let* ((admin #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
- (if (not (null? data-row))
- (let ((col (car data-row)))
- (if (equal? col "read-admin")
- (set! admin #t)))))))
-admin))
-
-
-;;check if user has specifc role for a area
-(define (is-user role username area)
- (let* ((has-access #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
- (if (not (null? data-row))
- (begin
- (let* ((access-type (car data-row))
- (exdate (cadr data-row)))
- (if (not (null? exdate))
- (begin
- (let ((valid (is-access-valid exdate)))
- ;(print valid)
- (if (and (equal? access-type role)
- (equal? valid #t))
- (set! has-access #t))))
- (print "Access expired"))))))))
- ;(print has-access)
-has-access))
-
-(define (is-access-valid exp-str)
- (let* ((ret-val #f )
- (date-parts (string-split exp-str "/"))
- (yr (string->number (car date-parts)))
- (month (string->number(car (cdr date-parts))))
- (day (string->number(caddr date-parts)))
- (exp-date (make-date 0 0 0 0 day month yr )))
- ;(print exp-date)
- ;(print (current-date))
- (if (> (date-compare exp-date (current-date)) 0)
- (set! ret-val #t))
- ;(print ret-val)
- ret-val))
-
-
-;check if area exists
-(define (area-exists area)
- (let* ((area-defined #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
- (if (not (null? data-row))
- (set! area-defined #t)))))
-area-defined))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; Get Record from database
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;gets area id by code
-(define (get-area area)
- (let* ((area-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
- (set! area-defined data-row))))
-area-defined))
-
-;get id of users table by user name
-(define (get-user user)
- (let* ((user-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'")))))
- (set! user-defined data-row))))
-user-defined))
-
-;get permissions id by userid and area id
-(define (get-perm userid areaid)
- (let* ((user-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid)))))
- (set! user-defined data-row))))
-
-user-defined))
-
-(define (get-restrictions base-path usr)
-(let* ((user-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'")))))
- ;(print data-row)
- (set! user-defined data-row))))
- ; (print user-defined)
- (if (null? user-defined)
- ""
- (car user-defined))))
-
-
-(define (get-obj-by-path path)
- (let* ((obj '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'")))))
- (set! obj data-row))))
-obj))
-
-(define (get-obj-by-code code )
- (let* ((obj '()))
- (sauthorize:db-do (lambda (db)
- ;(print (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'"))
- (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'")))))
- ;(print data-row)
- (set! obj data-row)
- ;(print obj)
- )))
- (if (not (null? obj))
- (begin
- (let* ((req-grp (caddr (cddr obj))))
- (sauthorize:do-as-calling-user
- (lambda ()
- (sauth-common:check-user-groups req-grp))))))
-obj))
-
-(define (sauth-common:check-user-groups req-grp)
-(let* ((current-groups (get-groups) )
- (req-grp-list (string-split req-grp ",")))
- ;(print req-grp-list)
- (for-each (lambda (grp)
- (let ((grp-info (group-information grp)))
- ;(print grp-info " " grp)
- (if (not (equal? grp-info #f))
- (begin
- (if (not (member (caddr grp-info) current-groups))
- (begin
- (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
- (exit 1)))))))
- req-grp-list)))
-
-(define (get-obj-by-code-no-grp-validation code )
- (let* ((obj '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'")))))
- (set! obj data-row))))
-;(print obj)
-obj))
-
-
-(define (sauth-common:src-size path)
- (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path " | awk '{print $1}'")
- (lambda()
- (read-line)))))
- (string->number output)))
-
-(define (sauth-common:space-left-at-dest path)
- (let* ((output (run/string (pipe (df ,path ) (tail -1))))
- (size (caddr (cdr (string-split output " ")))))
- (string->number size)))
-
-;; function to validate the users input for target path and resolve the path
-;; TODO: Check for restriction in subpath
-(define (sauth-common:resolve-path new current allowed-sheets)
- (let* ((target-path (append current (string-split new "/")))
- (target-path-string (string-join target-path "/"))
- (normal-path (normalize-pathname target-path-string))
- (normal-list (string-split normal-path "/"))
- (ret '()))
- (if (string-contains normal-path "..")
- (begin
- (print "ERROR: Path " new " resolved outside target area ")
- #f)
- (if(equal? normal-path ".")
- ret
- (if (not (member (car normal-list) allowed-sheets))
- (begin
- (print "ERROR: Permision denied to " new )
- #f)
- normal-list)))))
-
-(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
- (usr (current-user-name) ) )
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- #f
- (let* ((sheet (car resolved-path))
- (restricted-areas (get-restrictions base-path usr))
- (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
- (target-path (if (null? (cdr resolved-path))
- base-path
- (conc base-path "/" (string-join (cdr resolved-path) "/")))))
-
-
- (if (and (not (equal? restricted-areas "" ))
- (string-match (regexp restrictions) target-path))
- (begin
- (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
- ;(exit 1)
- #f)
- target-path)
-
-))
- #f)))
-
-(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
- (if (and (null? base-path-list) (equal? ext-path "") )
- (print (string-intersperse top-areas " "))
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
- ;(print resolved-path)
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- (print (string-intersperse top-areas " "))
- (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path)))
- (print target-path)
- (if (not (equal? target-path #f))
- (begin
- (cond
- ((null? tail-cmd-list)
- (run (pipe
- (ls "-lrt" ,target-path))))
- ((not (equal? (car tail-cmd-list) "|"))
- (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
- (else
- (run (pipe
- (ls "-lrt" ,target-path)
- (begin (system (string-join (cdr tail-cmd-list))))))))))))))))
-
-(define (sauth:print-error msg)
- (with-output-to-port (current-error-port)
- (lambda ()
- (print (conc "ERROR: " msg)))))
-
ADDED sauth/sauth-common.scm
Index: sauth/sauth-common.scm
==================================================================
--- /dev/null
+++ sauth/sauth-common.scm
@@ -0,0 +1,328 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+
+;; Create the sqlite db
+(define (sauthorize:db-do proc)
+ (if (or (not *db-path*)
+ (not (file-exists? *db-path*)))
+ (begin
+ (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
+ (exit 1)))
+ (if (and *db-path*
+ (directory? *db-path*)
+ (file-read-access? *db-path*))
+ (let* ((dbpath (conc *db-path* "/sauthorize.db"))
+ (writeable (file-write-access? dbpath))
+ (dbexists (file-exists? dbpath)))
+ (handle-exceptions
+ exn
+ (begin
+ (print 2 "ERROR: problem accessing db " dbpath
+ ((condition-property-accessor 'exn 'message) exn))
+ (exit 1))
+ ;(print "calling proc " proc "db path " dbpath )
+ (call-with-database
+ dbpath
+ (lambda (db)
+ ;(print 0 "calling proc " proc " on db " db)
+ (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+ (if (not dbexists)(sauthorize:initialize-db db))
+ (proc db)))))
+ (print 0 "ERROR: invalid path for storing database: " *db-path*)))
+
+;;execute a query
+(define (sauthorize:db-qry db qry)
+ ;(print qry)
+ (exec (sql db qry)))
+
+
+(define (sauthorize:do-as-calling-user proc)
+ (let ((eid (current-effective-user-id))
+ (cid (current-user-id)))
+ (if (not (eq? eid cid)) ;; running suid
+ (set! (current-effective-user-id) cid))
+ ;(print 0 "cid " cid " eid:" eid)
+ (proc)
+ (if (not (eq? eid cid))
+ (set! (current-effective-user-id) eid))))
+
+
+(define (run-cmd cmd arg-list)
+ ; (print (current-effective-user-id))
+ ;(handle-exceptions
+; exn
+; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
+ (let ((pid (process-run cmd arg-list)))
+ (process-wait pid))
+)
+;)
+
+
+(define (regster-log inl usr-id area-id cmd)
+ (sauth-common:shell-do-as-adm
+ (lambda ()
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )")))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Check user types
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;check if a user is an admin
+(define (is-admin username)
+ (let* ((admin #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
+ (if (not (null? data-row))
+ (let ((col (car data-row)))
+ (if (equal? col "yes")
+ (set! admin #t)))))))
+admin))
+
+
+;;check if a user is an read-admin
+(define (is-read-admin username)
+ (let* ((admin #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
+ (if (not (null? data-row))
+ (let ((col (car data-row)))
+ (if (equal? col "read-admin")
+ (set! admin #t)))))))
+admin))
+
+
+;;check if user has specifc role for a area
+(define (is-user role username area)
+ (let* ((has-access #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
+ (if (not (null? data-row))
+ (begin
+ (let* ((access-type (car data-row))
+ (exdate (cadr data-row)))
+ (if (not (null? exdate))
+ (begin
+ (let ((valid (is-access-valid exdate)))
+ ;(print valid)
+ (if (and (equal? access-type role)
+ (equal? valid #t))
+ (set! has-access #t))))
+ (print "Access expired"))))))))
+ ;(print has-access)
+has-access))
+
+(define (is-access-valid exp-str)
+ (let* ((ret-val #f )
+ (date-parts (string-split exp-str "/"))
+ (yr (string->number (car date-parts)))
+ (month (string->number(car (cdr date-parts))))
+ (day (string->number(caddr date-parts)))
+ (exp-date (make-date 0 0 0 0 day month yr )))
+ ;(print exp-date)
+ ;(print (current-date))
+ (if (> (date-compare exp-date (current-date)) 0)
+ (set! ret-val #t))
+ ;(print ret-val)
+ ret-val))
+
+
+;check if area exists
+(define (area-exists area)
+ (let* ((area-defined #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
+ (if (not (null? data-row))
+ (set! area-defined #t)))))
+area-defined))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Get Record from database
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;gets area id by code
+(define (get-area area)
+ (let* ((area-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
+ (set! area-defined data-row))))
+area-defined))
+
+;get id of users table by user name
+(define (get-user user)
+ (let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'")))))
+ (set! user-defined data-row))))
+user-defined))
+
+;get permissions id by userid and area id
+(define (get-perm userid areaid)
+ (let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid)))))
+ (set! user-defined data-row))))
+
+user-defined))
+
+(define (get-restrictions base-path usr)
+(let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'")))))
+ ;(print data-row)
+ (set! user-defined data-row))))
+ ; (print user-defined)
+ (if (null? user-defined)
+ ""
+ (car user-defined))))
+
+
+(define (get-obj-by-path path)
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'")))))
+ (set! obj data-row))))
+obj))
+
+(define (get-obj-by-code code )
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ ;(print (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'"))
+ (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'")))))
+ ;(print data-row)
+ (set! obj data-row)
+ ;(print obj)
+ )))
+ (if (not (null? obj))
+ (begin
+ (let* ((req-grp (caddr (cddr obj))))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (sauth-common:check-user-groups req-grp))))))
+obj))
+
+(define (sauth-common:check-user-groups req-grp)
+(let* ((current-groups (get-groups) )
+ (req-grp-list (string-split req-grp ",")))
+ ;(print req-grp-list)
+ (for-each (lambda (grp)
+ (let ((grp-info (group-information grp)))
+ ;(print grp-info " " grp)
+ (if (not (equal? grp-info #f))
+ (begin
+ (if (not (member (caddr grp-info) current-groups))
+ (begin
+ (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
+ (exit 1)))))))
+ req-grp-list)))
+
+(define (get-obj-by-code-no-grp-validation code )
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'")))))
+ (set! obj data-row))))
+;(print obj)
+obj))
+
+
+(define (sauth-common:src-size path)
+ (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path " | awk '{print $1}'")
+ (lambda()
+ (read-line)))))
+ (string->number output)))
+
+(define (sauth-common:space-left-at-dest path)
+ (let* ((output (run/string (pipe (df ,path ) (tail -1))))
+ (size (caddr (cdr (string-split output " ")))))
+ (string->number size)))
+
+;; function to validate the users input for target path and resolve the path
+;; TODO: Check for restriction in subpath
+(define (sauth-common:resolve-path new current allowed-sheets)
+ (let* ((target-path (append current (string-split new "/")))
+ (target-path-string (string-join target-path "/"))
+ (normal-path (normalize-pathname target-path-string))
+ (normal-list (string-split normal-path "/"))
+ (ret '()))
+ (if (string-contains normal-path "..")
+ (begin
+ (print "ERROR: Path " new " resolved outside target area ")
+ #f)
+ (if(equal? normal-path ".")
+ ret
+ (if (not (member (car normal-list) allowed-sheets))
+ (begin
+ (print "ERROR: Permision denied to " new )
+ #f)
+ normal-list)))))
+
+(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
+ (usr (current-user-name) ) )
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ #f
+ (let* ((sheet (car resolved-path))
+ (restricted-areas (get-restrictions base-path usr))
+ (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
+ (target-path (if (null? (cdr resolved-path))
+ base-path
+ (conc base-path "/" (string-join (cdr resolved-path) "/")))))
+
+
+ (if (and (not (equal? restricted-areas "" ))
+ (string-match (regexp restrictions) target-path))
+ (begin
+ (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
+ ;(exit 1)
+ #f)
+ target-path)
+
+))
+ #f)))
+
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+ (if (and (null? base-path-list) (equal? ext-path "") )
+ (print (string-intersperse top-areas " "))
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+ ;(print resolved-path)
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print (string-intersperse top-areas " "))
+ (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path)))
+ (print target-path)
+ (if (not (equal? target-path #f))
+ (begin
+ (cond
+ ((null? tail-cmd-list)
+ (run (pipe
+ (ls "-lrt" ,target-path))))
+ ((not (equal? (car tail-cmd-list) "|"))
+ (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
+ (else
+ (run (pipe
+ (ls "-lrt" ,target-path)
+ (begin (system (string-join (cdr tail-cmd-list))))))))))))))))
+
+(define (sauth:print-error msg)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print (conc "ERROR: " msg)))))
+
ADDED sauth/sauthorize.scm
Index: sauth/sauthorize.scm
==================================================================
--- /dev/null
+++ sauth/sauthorize.scm
@@ -0,0 +1,651 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+
+(use defstruct)
+(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 margs))
+
+(include "megatest-version.scm")
+(include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+ list : list areas $USER's can access
+ log : get listing of recent activity.
+ sauth list-area-user : list the users that can access the area.
+ sauth open --group : Open up an area. User needs to be the owner of the area to open it.
+ --code
+ --retrieve|--publish [--additional-grps ]
+ sauth update --retrieve|--publish : update the binaries with the lates changes
+ sauth grant --area : Grant permission to read or write to a area that is alrady opend up.
+ --expiration yyyy/mm/dd --retrieve|--publish
+ [--restrict ]
+ sauth read-shell : Open sretrieve shell for reading.
+ sauth write-shell : Open spublish shell for writing.
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+(define (sauthorize:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (exec (sql db qry)))
+ (list
+ "CREATE TABLE IF NOT EXISTS actions
+ (id INTEGER PRIMARY KEY,
+ cmd TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ comment TEXT DEFAULT '' NOT NULL,
+ action_type TEXT NOT NULL);"
+ "CREATE TABLE IF NOT EXISTS users
+ (id INTEGER PRIMARY KEY,
+ username TEXT NOT NULL,
+ is_admin TEXT NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS areas
+ (id INTEGER PRIMARY KEY,
+ basepath TEXT NOT NULL,
+ code TEXT NOT NULL,
+ exe_name TEXT NOT NULL,
+ required_grps TEXT DEFAULT '' NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS permissions
+ (id INTEGER PRIMARY KEY,
+ access_type TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ restriction TEXT DEFAULT '' NOT NULL,
+ expiration TIMESTAMP DEFAULT NULL);"
+ )))
+
+
+
+
+(define (get-access-type args)
+ (let loop ((hed (car args))
+ (tal (cdr args)))
+ (cond
+ ((equal? hed "--retrieve")
+ "retrieve")
+ ((equal? hed "--publish")
+ "publish")
+ ((equal? hed "--area-admin")
+ "area-admin")
+ ((equal? hed "--writer-admin")
+ "writer-admin")
+ ((equal? hed "--read-admin")
+ "read-admin")
+
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+
+
+;; check if user can gran access to an area
+(define (can-grant-perm username access-type area)
+ (let* ((isadmin (is-admin username))
+ (is-area-admin (is-user "area-admin" username area ))
+ (is-read-admin (is-user "read-admin" username area) )
+ (is-writer-admin (is-user "writer-admin" username area) ) )
+ (cond
+ ((equal? isadmin #t)
+ #t)
+ ((equal? is-area-admin #t )
+ #t)
+ ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
+ #t)
+ ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
+ #t)
+
+ (else
+ #f))))
+
+(define (sauthorize:list-areausers area )
+ (sauthorize:db-do (lambda (db)
+ (print "Users having access to " area ":")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (cadr row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse row " | "))))))
+ (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
+
+
+
+
+; check if executable exists
+(define (exe-exist exe access-type)
+ (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
+ ; (print filepath)
+ (if (file-exists? filepath)
+ #t
+ #f)))
+
+(define (copy-exe access-type exe-name group)
+ (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
+ (let* ((spath (conc *exe-src* "/s" access-type))
+ (dpath (conc *exe-path* "/" access-type "/" exe-name)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd "/bin/cp" (list spath dpath ))
+ (if (equal? access-type "publish")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (if (equal? group "none")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (run-cmd "/bin/chgrp" (list group dpath))
+ (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
+ (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
+
+(define (get-exe-name path group)
+ (let ((name ""))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (if (equal? (current-effective-user-id) (file-owner path))
+ (set! name (conc (current-user-name) "_" group))
+ (begin
+ (print "You cannot open areas that you dont own!!")
+ (exit 1)))))
+name))
+
+(define (sauthorize:valid-unix-user username)
+ (let* ((ret-val #f))
+ (let-values (((inp oup pid)
+ (process "/usr/bin/id" (list username))))
+ (let loop ((inl (read-line inp)))
+ (if (string? inl)
+ (if (string-contains inl "No such user")
+ (set! ret-val #f)
+ (set! ret-val #t)))
+ (if (eof-object? inl)
+ (begin
+ (close-input-port inp)
+ (close-output-port oup))
+ (loop (read-line inp)))))
+ ret-val))
+
+
+;check if a paths/codes are vaid and if area is alrady open
+(define (open-area group path code access-type other-grps)
+ (let* ((exe-name (get-exe-name path group))
+ (path-obj (get-obj-by-path path))
+ (code-obj (get-obj-by-code-no-grp-validation code)))
+ ;(print path-obj)
+ (cond
+ ((not (null? path-obj))
+ (if (equal? code (car path-obj))
+ (begin
+ (if (equal? exe-name (cadr path-obj))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group)
+ (begin
+ (print "Area already open!!")
+ (exit 1))))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ ;; update exe-name in db
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
+ )))
+ (begin
+ (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
+ (exit 1))))
+
+ ((not (null? code-obj))
+ (print "Code " code " is used for diffrent path. Please try diffrent value of --code" )
+ (exit 1))
+ (else
+ ; (print (exe-exist exe-name access-type))
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ (sauthorize:db-do (lambda (db)
+ (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ")
+ (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
+
+(define (user-has-open-perm user path access)
+ (let* ((has-access #f)
+ (eid (current-user-id)))
+ (cond
+ ((is-admin user)
+ (set! has-access #t ))
+ ((and (is-read-admin user) (equal? access "retrieve"))
+ (set! has-access #t ))
+ (else
+ (print "User " user " does not have permission to open areas")))
+ has-access))
+
+
+;;check if user has group access
+(define (is-group-washed req_grpid current-grp-list)
+ (let loop ((hed (car current-grp-list))
+ (tal (cdr current-grp-list)))
+ (cond
+ ((equal? hed req_grpid)
+ #t)
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+;create executables with appropriate suids
+(define (sauthorize:open user path group code access-type other-groups)
+ (let* ((gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (and (not (equal? group "none")) (equal? valid-grp #f ))
+ (begin
+ (print "Group " group " is not washed in the current xterm!!")
+ (exit 1))))
+ (if (not (file-write-access? path))
+ (begin
+ (print "You can open areas owned by yourself. You do not have permissions to open path." path)
+ (exit 1)))
+ (if (user-has-open-perm user path access-type)
+ (begin
+ ;(print "here")
+ (open-area group path code access-type other-groups)
+ (sauthorize:grant user user code "2017/12/25" "read-admin" "")
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
+ (print "Area has " path " been opened for " access-type ))))
+
+(define (sauthorize:update username exe area access-type)
+ (let* ((parts (string-split exe "_"))
+ (owner (car parts))
+ (group (cadr parts))
+ (gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (not (equal? username owner))
+ (begin
+ (print "You cannot update " area ". Only " owner " can update this area!!")
+ (exit 1)))
+ (copy-exe access-type exe group)
+ (print "recording action..")
+ (sauthorize:db-do (lambda (db)
+
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
+ (print "Area has " area " been update!!" )))
+
+(define (sauthorize:grant auser guser area exp-date access-type restrict)
+ ; check if user exist in db
+ (let* ((area-obj (get-area area))
+ (auser-obj (get-user auser))
+ (user-obj (get-user guser)))
+
+ (if (null? user-obj)
+ (begin
+ ;; is guser a valid unix user
+ (if (not (sauthorize:valid-unix-user guser))
+ (begin
+ (print "User " guser " is Invalid unix user!!")
+ (exit 1)))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
+ (set! user-obj (get-user guser))))
+ (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
+ (if(null? perm-obj)
+ (begin
+ ;; insert permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
+ (begin
+ ;update permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))
+ (print "Permission has been sucessfully granted to user " guser))))
+
+(define (sauthorize:process-action username action . args)
+ (case (string->symbol action)
+ ((grant)
+ (if (< (length args) 6)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
+ (guser (car args))
+ (restrict (or (args:get-arg "--restrict") ""))
+ (area (or (args:get-arg "--area") ""))
+ (exp-date (or (args:get-arg "--expiration") ""))
+ (access-type (get-access-type remargs)))
+ ; (print "version " guser " restrict " restrict )
+ ; (print "area " area " exp-date " exp-date " access-type " access-type)
+ (cond
+ ((equal? guser "")
+ (print "Username not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "Area not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? exp-date "")
+ (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+ (if (can-grant-perm username access-type area)
+ (begin
+ (print "calling sauthorize:grant ")
+ (sauthorize:grant username guser area exp-date access-type restrict))
+ (begin
+ (print "User " username " does not have permission to grant permissions to area " area "!!")
+ (exit 1)))))
+ ((list-area-user)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to list-area-user ")
+ (exit 1)))
+ (let* ((area (car args)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+
+ (sauthorize:list-areausers area )
+ ))
+ ((read-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
+ ((write-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for Writing!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
+ ((publish)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish [opts] ")
+ (exit 1)))
+
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ ;(print "area " area)
+ ;(print "code: " code-obj)
+ ;(print (exe-exist (cadr code-obj) "publish"))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for writing!!")
+ (exit 1)))
+ ;(print "hear")
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ ; (print *exe-path* "/publish/" (cadr code-obj) action area cmd-args )
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+ ((retrieve)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish [opts] ")
+ (exit 1)))
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+
+
+ ((open)
+ (if (< (length args) 6)
+ (begin
+ (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open --group --code --retrieve|--publish")
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
+ (path (car args))
+ (group (or (args:get-arg "--group") ""))
+ (area (or (args:get-arg "--code") ""))
+ (other-grps (or (args:get-arg "--additional-grps") ""))
+ (access-type (get-access-type remargs)))
+
+ (cond
+ ((equal? path "")
+ (print "path not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "--code not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((and (not (equal? access-type "publish"))
+ (not (equal? access-type "retrieve")))
+ (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+ ; (print other-grps)
+ (sauthorize:open username path group area access-type other-grps)))
+ ((update)
+ (if (< (length args) 2)
+ (begin
+ (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update --retrieve|--publish")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area))
+ (access-type (get-access-type (cdr args))))
+ (if (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
+ (begin
+ (print "Access type can be --retrieve|--publish ")
+ (exit 1)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) access-type)))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:update username (cadr code-obj) area access-type )))
+ ((area-admin)
+ (let* ((usr (car args))
+ (usr-obj (get-user usr))
+ (user-id (car (get-user username))))
+
+ (if (is-admin username)
+ (begin
+ ; (print usr-obj)
+ (if (null? usr-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
+ (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
+ (begin
+ ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
+ (print "User " usr " is updated with area-admin access!"))
+ (print "Admin only function"))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" ))))))
+ ((mk-admin)
+ (let* ((usr (car args))
+ (usr-obj (get-user usr))
+ (user-id (car (get-user username))))
+ (if (not (sauthorize:valid-unix-user usr))
+ (begin
+ (print "User " usr " is Invalid unix user!!")
+ (exit 1)))
+
+ (if (member username *super-users*)
+ (begin
+ (if (null? usr-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
+ (print "User " usr " is updated with admin access!"))
+ (print "Super-Admin only function"))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" ))))))
+
+ ((register-log)
+ (if (< (length args) 4)
+ (print "Invalid arguments"))
+ ;(print args)
+ (let* ((cmd-line (car args))
+ (user-id (cadr args))
+ (area-id (caddr args))
+ (user-obj (get-user username))
+ (cmd (cadddr args)))
+
+ (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
+ (print "You ar not authorised to run this cmd")
+
+)))
+
+
+ (else (print 0 "Unrecognised command " action))))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (username (current-user-name)))
+ ;; preserve the exe data in the config file
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print sauthorize:help))
+ ((list)
+
+ (sauthorize:db-do (lambda (db)
+ (print "My Area accesses: ")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (car row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse (cdr row) " | "))))))
+ (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
+
+ ((log)
+ (sauthorize:db-do (lambda (db)
+ (print "Logs : ")
+ (query (for-each-row
+ (lambda (row)
+
+ (apply print (intersperse row " | "))))
+ (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
+ (else
+ (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
+ ;; multi-word commands
+ ((null? rema)(print sauthorize:help))
+ ((>= (length rema) 2)
+ (apply sauthorize:process-action username (car rema)(cdr rema)))
+ (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
+
+(main)
+
+
+
ADDED sauth/spublish.scm
Index: sauth/spublish.scm
==================================================================
--- /dev/null
+++ sauth/spublish.scm
@@ -0,0 +1,820 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+(use defstruct)
+(use scsh-process)
+(use refdb)
+(use srfi-18)
+(use srfi-19)
+(use format)
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+
+;(declare (uses configf))
+;; (declare (uses tree))
+(declare (uses margs))
+
+(include "megatest-version.scm")
+(include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+(define (toplevel-command . args) #f)
+(use readline)
+
+;;
+;; GLOBALS
+;;
+(define *spublish:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define spublish:help (conc "Usage: spublish [action [params ...]]
+
+ ls : list contents of target area
+ cp|publish : copy file to target area
+ mkdir : maks directory in target area
+ rm : remove file from target area
+ ln : creates a symlink
+
+ options:
+
+ -m \"message\" : describe what was done
+Note: All the target locations relative to base path
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+(define *default-log-port* (current-error-port))
+(define *verbosity* 1)
+
+;(define (spublish:initialize-db db)
+; (for-each
+; (lambda (qry)
+; (exec (sql db qry)))
+; (list
+; "CREATE TABLE IF NOT EXISTS actions
+; (id INTEGER PRIMARY KEY,
+; action TEXT NOT NULL,
+; submitter TEXT NOT NULL,
+; datetime TIMESTAMP DEFAULT (strftime('%s','now')),
+; srcpath TEXT NOT NULL,
+; comment TEXT DEFAULT '' NOT NULL,
+; state TEXT DEFAULT 'new');"
+; )))
+
+;(define (spublish:register-action db action submitter source-path comment)
+; (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment)
+; VALUES(?,?,?,?)")
+; action
+; submitter
+; source-path
+; comment))
+
+;; (call-with-database
+;; (lambda (db)
+;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
+;; ...))
+
+;; Create the sqlite db
+;(define (spublish:db-do configdat proc)
+; (let ((path (configf:lookup configdat "database" "location")))
+; (if (not path)
+; (begin
+; (print "[database]\nlocation /some/path\n\n Is missing from the config file!")
+; (exit 1)))
+; (if (and path
+; (directory? path)
+; (file-read-access? path))
+; (let* ((dbpath (conc path "/spublish.db"))
+; (writeable (file-write-access? dbpath))
+; (dbexists (file-exists? dbpath)))
+; (handle-exceptions
+; exn
+; (begin
+; (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
+; ((condition-property-accessor 'exn 'message) exn))
+; (exit 1))
+; (call-with-database
+; dbpath
+; (lambda (db)
+; ;; (print "calling proc " proc " on db " db)
+; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+; (if (not dbexists)(spublish:initialize-db db))
+; (proc db)))))
+; (print "ERROR: invalid path for storing database: " path))))
+;
+;;; copy in file to dest, validation is done BEFORE calling this
+;;;
+;(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment)
+; (let ((dest-dir-path (conc target-dir "/" dest-dir))
+; (targ-path (conc target-dir "/" dest-dir "/" targ-file)))
+; (if (file-exists? targ-path)
+; (begin
+; (print "ERROR: target file already exists, remove it before re-publishing")
+; (exit 1)))
+; (if (not(file-exists? dest-dir-path))
+; (begin
+; (print "ERROR: target directory " dest-dir-path " does not exists." )
+; (exit 1)))
+;
+; (spublish:db-do
+; configdat
+; (lambda (db)
+; (spublish:register-action db "cp" submitter source-path comment)))
+; (let* (;; (target-path (configf:lookup "settings" "target-path"))
+; (th1 (make-thread
+; (lambda ()
+; (file-copy source-path targ-path #t))
+; (print " ... file " targ-path " copied to " targ-path)
+; ;; (let ((pid (process-run "cp" (list source-path target-dir))))
+; ;; (process-wait pid)))
+; "copy thread"))
+; (th2 (make-thread
+; (lambda ()
+; (let loop ()
+; (thread-sleep! 15)
+; (display ".")
+; (flush-output)
+; (loop)))
+; "action is happening thread")))
+; (thread-start! th1)
+; (thread-start! th2)
+; (thread-join! th1))
+; (cons #t "Successfully saved data")))
+;
+;;; copy directory to dest, validation is done BEFORE calling this
+;;;
+;
+;(define (spublish:tar configdat submitter target-dir dest-dir comment)
+; (let ((dest-dir-path (conc target-dir "/" dest-dir)))
+; (if (not(file-exists? dest-dir-path))
+; (begin
+; (print "ERROR: target directory " dest-dir-path " does not exists." )
+; (exit 1)))
+; ;;(print dest-dir-path )
+; (spublish:db-do
+; configdat
+; (lambda (db)
+; (spublish:register-action db "tar" submitter dest-dir-path comment)))
+; (change-directory dest-dir-path)
+; (process-wait (process-run "/bin/tar" (list "xf" "-")))
+; (print "Data copied to " dest-dir-path)
+;
+; (cons #t "Successfully saved data")))
+
+
+;(define (spublish:validate target-dir targ-mk)
+; (let* ((normal-path (normalize-pathname targ-mk))
+; (targ-path (conc target-dir "/" normal-path)))
+; (if (string-contains normal-path "..")
+; (begin
+; (print "ERROR: Path " targ-mk " resolved outside target area " target-dir )
+; (exit 1)))
+;
+; (if (not (string-contains targ-path target-dir))
+; (begin
+; (print "ERROR: You cannot update data outside " target-dir ".")
+; (exit 1)))
+; (print "Path " targ-mk " is valid.")
+; ))
+;; make directory in dest
+;;
+
+;(define (spublish:mkdir configdat submitter target-dir targ-mk comment)
+; (let ((targ-path (conc target-dir "/" targ-mk)))
+;
+; (if (file-exists? targ-path)
+; (begin
+; (print "ERROR: target Directory " targ-path " already exist!!")
+; (exit 1)))
+; (spublish:db-do
+; configdat
+; (lambda (db)
+; (spublish:register-action db "mkdir" submitter targ-mk comment)))
+; (let* ((th1 (make-thread
+; (lambda ()
+; (create-directory targ-path #t)
+; (print " ... dir " targ-path " created"))
+; "mkdir thread"))
+; (th2 (make-thread
+; (lambda ()
+; (let loop ()
+; (thread-sleep! 15)
+; (display ".")
+; (flush-output)
+; (loop)))
+; "action is happening thread")))
+; (thread-start! th1)
+; (thread-start! th2)
+; (thread-join! th1))
+; (cons #t "Successfully saved data")))
+
+;; create a symlink in dest
+;;
+;(define (spublish:ln configdat submitter target-dir targ-link link-name comment)
+; (let ((targ-path (conc target-dir "/" link-name)))
+; (if (file-exists? targ-path)
+; (begin
+; (print "ERROR: target file " targ-path " already exist!!")
+; (exit 1)))
+; (if (not (file-exists? targ-link ))
+; (begin
+; (print "ERROR: target file " targ-link " does not exist!!")
+; (exit 1)))
+;
+; (spublish:db-do
+; configdat
+; (lambda (db)
+; (spublish:register-action db "ln" submitter link-name comment)))
+; (let* ((th1 (make-thread
+; (lambda ()
+; (create-symbolic-link targ-link targ-path )
+; (print " ... link " targ-path " created"))
+; "symlink thread"))
+; (th2 (make-thread
+; (lambda ()
+; (let loop ()
+; (thread-sleep! 15)
+; (display ".")
+; (flush-output)
+; (loop)))
+; "action is happening thread")))
+; (thread-start! th1)
+; (thread-start! th2)
+; (thread-join! th1))
+; (cons #t "Successfully saved data")))
+
+
+;; remove copy of file in dest
+;;
+;(define (spublish:rm configdat submitter target-dir targ-file comment)
+; (let ((targ-path (conc target-dir "/" targ-file)))
+; (if (not (file-exists? targ-path))
+; (begin
+; (print "ERROR: target file " targ-path " not found, nothing to remove.")
+; (exit 1)))
+; (spublish:db-do
+; configdat
+; (lambda (db)
+; (spublish:register-action db "rm" submitter targ-file comment)))
+; (let* ((th1 (make-thread
+; (lambda ()
+; (delete-file targ-path)
+; (print " ... file " targ-path " removed"))
+; "rm thread"))
+; (th2 (make-thread
+; (lambda ()
+; (let loop ()
+; (thread-sleep! 15)
+; (display ".")
+; (flush-output)
+; (loop)))
+; "action is happening thread")))
+; (thread-start! th1)
+; (thread-start! th2)
+; (thread-join! th1))
+; (cons #t "Successfully saved data")))
+
+(define (spublish:backup-move path)
+ (let* ((trashdir (conc (pathname-directory path) "/.trash"))
+ (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+ (create-directory trashdir #t)
+ (if (directory? path)
+ (system (conc "mv " path " " trashfile))
+ (file-move path trash-file))))
+
+
+(define (spublish:lst->path pathlst)
+ (conc "/" (string-intersperse (map conc pathlst) "/")))
+
+(define (spublish:path->lst path)
+ (string-split path "/"))
+
+(define (spublish:pathdat-apply-heuristics configdat path)
+ (cond
+ ((file-exists? path) "found")
+ (else (conc path " not installed"))))
+
+;;======================================================================
+;; MISC
+;;======================================================================
+
+;(define (spublish:do-as-calling-user proc)
+; (let ((eid (current-effective-user-id))
+; (cid (current-user-id)))
+; (if (not (eq? eid cid)) ;; running suid
+; (set! (current-effective-user-id) cid))
+; ;; (print "running as " (current-effective-user-id))
+; (proc)
+; (if (not (eq? eid cid))
+; (set! (current-effective-user-id) eid))))
+
+;(define (spublish:find name paths)
+; (if (null? paths)
+; #f
+; (let loop ((hed (car paths))
+; (tal (cdr paths)))
+; (if (file-exists? (conc hed "/" name))
+; hed
+; (if (null? tal)
+; #f
+; (loop (car tal)(cdr tal)))))))
+
+;;========================================================================
+;;Shell
+;;========================================================================
+(define (spublish:get-accessable-projects area)
+ (let* ((projects `()))
+ (if (spublish:has-permission area)
+ (set! projects (cons area projects))
+ (begin
+ (print "User cannot access area " area "!!")
+ (exit 1)))
+ projects))
+
+;; function to find sheets to which use has access
+(define (spublish:has-permission area)
+ ;(print "in spublish:has-permission")
+ (let* ((username (current-user-name))
+ (ret-val #f))
+ (cond
+ ((equal? (is-admin username) #t)
+ (set! ret-val #t))
+ ((equal? (is-user "publish" username area) #t)
+ (set! ret-val #t))
+ ((equal? (is-user "writer-admin" username area) #t)
+ (set! ret-val #t))
+
+ ((equal? (is-user "area-admin" username area) #t)
+ (set! ret-val #t))
+ (else
+ (set! ret-val #f)))
+ ret-val))
+
+(define (is_directory target-path)
+ (let* ((retval #f))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ ;(print (current-effective-user-id) )
+ (if (directory? target-path)
+ (set! retval #t))))
+ ;(print (current-effective-user-id))
+ retval))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; shell functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (spublish:shell-cp src-path target-path)
+ (cond
+ ((not (file-exists? target-path))
+ (sauth:print-error (conc " target Directory " target-path " does not exist!!")))
+ ((not (file-exists? src-path))
+ (sauth:print-error (conc "Source path " src-path " does not exist!!" )))
+ (else
+ (if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
+ (begin
+ (sauth:print-error "Destination does not have enough disk space.")
+ (exit 1)))
+ (if (is_directory src-path)
+ (begin
+ (let* ((parent-dir src-path)
+ (start-dir target-path))
+ (run (pipe
+ (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
+ (begin (change-directory start-dir)
+ ;(print "123")
+ (run-cmd "tar" (list "xf" "-")))))
+ (print "Copied data to " start-dir)))
+ (begin
+ (let*((parent-dir (pathname-directory src-path))
+ (start-dir target-path)
+ (filename (if (pathname-extension src-path)
+ (conc(pathname-file src-path) "." (pathname-extension src-path))
+ (pathname-file src-path))))
+ ;(print "parent-dir " parent-dir " start-dir " start-dir)
+ (run (pipe
+ (begin (system (conc "cd " parent-dir ";tar chf - " filename )))
+ (begin (change-directory start-dir)
+ (run-cmd "tar" (list "xf" "-")))))
+ (print "Copied data to " start-dir)))))))
+
+
+(define (spublish:shell-mkdir targ-path)
+ (if (file-exists? targ-path)
+ (begin
+ (print "Info: Target Directory " targ-path " already exist!!"))
+ (let* ((th1 (make-thread
+ (lambda ()
+ (create-directory targ-path #t)
+ (print " ... dir " targ-path " created"))
+ "mkdir thread"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 15)
+ (display ".")
+ (flush-output)
+ (loop)))
+ "action is happening thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ (cons #t "Successfully saved data"))))
+
+
+(define (spublish:shell-rm targ-path iport)
+ (if (not (file-exists? targ-path))
+ (begin
+ (sauth:print-error (conc "target path " targ-path " does not exist!!")))
+ (begin
+ (print "Are you sure you want to delete " targ-path "?[y/n]")
+ (let* ((inl (read-line iport)))
+ (if (equal? inl "y")
+ (let* ((th1 (make-thread
+ (lambda ()
+ (if (symbolic-link? targ-path)
+ (delete-file targ-path )
+ (if (directory? targ-path)
+ (delete-directory targ-path #t)
+ (delete-file targ-path )))
+ (print " ... path " targ-path " deleted"))
+ "rm thread"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 15)
+ (display ".")
+ (flush-output)
+ (loop)))
+ "action is happening thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ (cons #t "Successfully saved data")))))))
+
+(define (spublish:shell-ln src-path target-path sub-path)
+ (if (not (file-exists? sub-path))
+ (sauth:print-error (conc "Path " sub-path " does not exist!! cannot proceed with link creation!!"))
+ (begin
+ (if (not (file-exists? src-path))
+ (sauth:print-error (conc "Path " src-path " does not exist!! cannot proceed with link creation!!"))
+ (begin
+ (if (file-exists? target-path)
+ (sauth:print-error (conc "Path " target-path "already exist!! cannot proceed with link creation!!"))
+ (begin
+ (create-symbolic-link src-path target-path )
+ (print " ... link " target-path " created"))))))))
+
+(define (spublish:shell-help)
+(conc "Usage: [action [params ...]]
+
+ ls [target path] : list contents of target area.
+ cd : To change the current directory within the sretrive shell.
+ pwd : Prints the full pathname of the current directory within the sretrive shell.
+ mkdir : creates directory. Note it does not create's a path recursive manner.
+ rm : removes files and emoty directories
+ cp : copy a file/dir to target path. if src is a dir it automatically makes a recursive copy.
+ ln TARGET LINK_NAME : creates a symlink
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)
+)
+
+(define (toplevel-command . args) #f)
+
+(define (spublish:shell area)
+ ; (print area)
+ (use readline)
+
+ (let* ((path '())
+ (prompt "spublish> ")
+ (args (argv))
+ (usr (current-user-name) )
+ (top-areas (spublish:get-accessable-projects area))
+ (close-port #f)
+ (area-obj (get-obj-by-code area))
+ (user-obj (get-user usr))
+ (base-path (if (null? area-obj)
+ ""
+ (caddr (cdr area-obj))))
+ (iport (make-readline-port prompt)))
+ ;(print base-path)
+ (if (null? area-obj)
+ (begin
+ (print "Area " area " does not exist")
+ (exit 1)))
+ ; (print "here")
+ (let loop ((inl (read-line iport)))
+ (if (not (or (or (eof-object? inl)
+ (equal? inl "exit")) (port-closed? iport)))
+ (let* ((parts (string-split inl))
+ (cmd (if (null? parts) #f (car parts))))
+ (if (and (not cmd) (not (port-closed? iport)))
+ (loop (read-line))
+ (case (string->symbol cmd)
+ ((cd)
+ (if (> (length parts) 1) ;; have a parameter
+ (begin
+ (let*((arg (cadr parts))
+ (resolved-path (sauth-common:resolve-path arg path top-areas))
+ (target-path (sauth-common:get-target-path path arg top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (or (equal? resolved-path #f) (not (file-exists? target-path)))
+ (print "Invalid argument " arg ".. ")
+ (begin
+ (set! path resolved-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd"))))
+ )))))
+ (set! path '())))
+ ((pwd)
+ (if (null? path)
+ (print "/")
+ (print "/" (string-join path "/"))))
+ ((ls)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (sauth-common:shell-ls-cmd path "" top-areas base-path '())
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) )
+ ((< plen 2)
+ (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '())
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))
+ (else
+ (if (equal? (car thepath) "|")
+ (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
+ (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))
+ ((mkdir)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (print "mkdir takes one argument"))
+ ((< plen 2)
+ (let*((mk-path (cadr parts))
+ (resolved-path (sauth-common:resolve-path mk-path path top-areas))
+ (target-path (sauth-common:get-target-path path mk-path top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " mk-path ".. ")
+ (begin
+ (print "here")
+ (spublish:shell-mkdir target-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir")))))))
+ )))))
+ ((rm)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (print "rm takes one argument"))
+ ((< plen 2)
+ (let*((rm-path (cadr parts))
+ (resolved-path (sauth-common:resolve-path rm-path path top-areas))
+ (target-path (sauth-common:get-target-path path rm-path top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " rm-path ".. ")
+ (begin
+ (spublish:shell-rm target-path iport)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))
+ )))))
+
+ ((cp publish)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((or (null? thepath) (< plen 2))
+ (print "cp takes two argument"))
+ ((< plen 3)
+ (let*((src-path (car thepath))
+ (dest-path (cadr thepath))
+ (resolved-path (sauth-common:resolve-path dest-path path top-areas))
+ (target-path (sauth-common:get-target-path path dest-path top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " dest-path ".. ")
+ (begin
+ (spublish:shell-cp src-path target-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp")))))))
+ )))))
+ ((ln)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((or (null? thepath) (< plen 2))
+ (print "ln takes two argument"))
+ ((< plen 3)
+ (let*((src-path (car thepath))
+ (dest-path (cadr thepath))
+ (resolved-path (sauth-common:resolve-path dest-path path top-areas))
+ (target-path (sauth-common:get-target-path path dest-path top-areas base-path))
+ (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/")))))
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " dest-path ".. ")
+ (begin
+ (spublish:shell-ln src-path target-path sub-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln")))))))
+ )))))
+ ((exit)
+ (print "got exit"))
+ ((help)
+ (print (spublish:shell-help)))
+ (else
+ (print "Got command: " inl))))
+ (loop (read-line iport)))))))
+
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+;(define (spublish:load-config exe-dir exe-name)
+; (let* ((fname (conc exe-dir "/." exe-name ".config")))
+ ;; (ini:property-separator-patt " * *")
+ ;; (ini:property-separator #\space)
+; (if (file-exists? fname)
+; ;; (ini:read-ini fname)
+; (read-config fname #f #t)
+; (make-hash-table))))
+
+(define (spublish:process-action action . args)
+ ;(print args)
+ (let* ((usr (current-user-name))
+ (user-obj (get-user usr))
+ (area (car args))
+ (area-obj (get-obj-by-code area))
+ (top-areas (spublish:get-accessable-projects area))
+ (base-path (if (null? area-obj)
+ ""
+ (caddr (cdr area-obj))))
+ (remargs (cdr args)))
+ (if (null? area-obj)
+ (begin
+ (print "Area " area " does not exist")
+ (exit 1)))
+ (case (string->symbol action)
+ ((cp publish)
+ (if (< (length remargs) 2)
+ (begin
+ (print "ERROR: Missing arguments; spublish " )
+ (exit 1)))
+ (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
+ (src-path-in (car filter-args))
+ (dest-path (cadr filter-args))
+ (src-path (with-input-from-pipe
+ (conc "readlink -f " src-path-in)
+ (lambda ()
+ (read-line))))
+ (msg (or (args:get-arg "-m") ""))
+ (resolved-path (sauth-common:resolve-path (conc area "/" dest-path) `() top-areas))
+ (target-path (sauth-common:get-target-path `() (conc area "/" dest-path) top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " dest-path ".. ")
+ (begin
+ (spublish:shell-cp src-path target-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp")))))))))
+ ((mkdir)
+ (if (< (length remargs) 1)
+ (begin
+ (print "ERROR: Missing arguments; ")
+ (exit 1)))
+ (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
+ (mk-path (car filter-args))
+ (msg (or (args:get-arg "-m") ""))
+ (resolved-path (sauth-common:resolve-path mk-path (list area) top-areas))
+ (target-path (sauth-common:get-target-path (list area) mk-path top-areas base-path)))
+ (print "attempting to create directory " mk-path )
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " mk-path ".. ")
+ (begin
+ (spublish:shell-mkdir target-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir")))))))))
+ ((ln)
+ (if (< (length remargs) 2)
+ (begin
+ (print "ERROR: Missing arguments; " )
+ (exit 1)))
+ (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
+ (src-path (car filter-args))
+ (dest-path (cadr filter-args))
+ (resolved-path (sauth-common:resolve-path dest-path (list area) top-areas))
+ (target-path (sauth-common:get-target-path (list area) dest-path top-areas base-path))
+ (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/")))))
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " dest-path ".. ")
+ (begin
+ (spublish:shell-ln src-path target-path sub-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" ln " src-path " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln")))))))))
+ ((rm)
+ (if (< (length remargs) 1)
+ (begin
+ (print "ERROR: Missing arguments; ")
+ (exit 1)))
+ (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
+ (rm-path (car filter-args))
+ (resolved-path (sauth-common:resolve-path rm-path (list area) top-areas))
+ (prompt ">")
+ (iport (make-readline-port prompt))
+ (target-path (sauth-common:get-target-path (list area) rm-path top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (equal? resolved-path #f)
+ (print "Invalid argument " rm-path ".. ")
+ (begin
+ (spublish:shell-rm target-path iport)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))))
+ ((shell)
+ (if (< (length args) 1)
+ (begin
+ (print "ERROR: Missing arguments area!!" )
+ (exit 1))
+ (spublish:shell area)))
+ (else (print "Unrecognised command " action)))))
+
+;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
+;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
+;; (if (file-exists? debugcontrolf)
+;; (load debugcontrolf)))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (exe-name (pathname-file (car (argv)))))
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print spublish:help))
+ (else
+ (print "ERROR: Unrecognised command. Try \"spublish help\""))))
+ ;; multi-word commands
+ ((null? rema)(print spublish:help))
+ ((>= (length rema) 2)
+ (apply spublish:process-action (car rema)(cdr rema)))
+ (else (print "ERROR: Unrecognised command2. Try \"spublish help\"")))))
+
+(main)
ADDED sauth/sretrieve.scm
Index: sauth/sretrieve.scm
==================================================================
--- /dev/null
+++ sauth/sretrieve.scm
@@ -0,0 +1,1112 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+
+(use defstruct)
+(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 margs))
+
+(include "megatest-version.scm")
+(include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+
+(define (toplevel-command . args) #f)
+(use readline)
+
+
+
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+ ls : list contents of target area
+ get : retrieve path to the data within
+ -m \"message\" : why retrieved?
+ shell : start a shell-like interface
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+;(define (sretrieve:initialize-db db)
+; (for-each
+; (lambda (qry)
+; (exec (sql db qry)))
+; (list
+; "CREATE TABLE IF NOT EXISTS actions
+; (id INTEGER PRIMARY KEY,
+; action TEXT NOT NULL,
+; retriever TEXT NOT NULL,
+; datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+; srcpath TEXT NOT NULL,
+; comment TEXT DEFAULT '' NOT NULL,
+; state TEXT DEFAULT 'new');"
+; "CREATE TABLE IF NOT EXISTS bundles
+; (id INTEGER PRIMARY KEY,
+; bundle TEXT NOT NULL,
+; release TEXT NOT NULL,
+; status TEXT NOT NULL,
+; event_date TEXT NOT NULL);"
+; )))
+;
+;(define (sretrieve:register-action db action submitter source-path comment)
+; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment)
+; (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment)
+; VALUES(?,?,?,?)")
+; action
+; submitter
+; source-path
+; (or comment "")))
+
+;; (call-with-database
+;; (lambda (db)
+;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
+;; ...))
+
+;; Create the sqlite db
+;(define (sretrieve:db-do configdat proc)
+; (let ((path (configf:lookup configdat "database" "location")))
+; (if (not path)
+; (begin
+; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
+; (exit 1)))
+; (if (and path
+; (directory? path)
+; (file-read-access? path))
+; (let* ((dbpath (conc path "/" *exe-name* ".db"))
+; (writeable (file-write-access? dbpath))
+; (dbexists (file-exists? dbpath)))
+; (handle-exceptions
+; exn
+; (begin
+; (debug:print 2 "ERROR: problem accessing db " dbpath
+; ((condition-property-accessor 'exn 'message) exn))
+; (exit 1))
+; ;;(debug:print 0 "calling proc " proc "db path " dbpath )
+; (call-with-database
+; dbpath
+; (lambda (db)
+; ;;(debug:print 0 "calling proc " proc " on db " db)
+; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+; (if (not dbexists)(sretrieve:initialize-db db))
+; (proc db)))))
+; (debug:print 0 "ERROR: invalid path for storing database: " path))))
+
+;; copy in directory to dest, validation is done BEFORE calling this
+;;
+;(define (sretrieve:get configdat retriever version comment)
+; (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
+; (datadir (conc base-dir "/" version)))
+; (if (or (not base-dir)
+; (not (file-exists? base-dir)))
+; (begin
+; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+; (exit 1)))
+; (print datadir)
+; (if (not (file-exists? datadir))
+; (begin
+; (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
+; (exit 1)))
+;
+; (sretrieve:db-do
+; configdat
+; (lambda (db)
+; (sretrieve:register-action db "get" retriever datadir comment)))
+; (sretrieve:do-as-calling-user
+; (lambda ()
+; (if (directory? datadir)
+; (begin
+; (change-directory datadir)
+; (let ((files (filter (lambda (x)
+; (not (member x '("." ".."))))
+; (glob "*" ".*"))))
+; (print "files: " files)
+; (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read")))))
+; (begin
+; (let* ((parent-dir (pathname-directory datadir) )
+; (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+; (change-directory parent-dir)
+; (process-execute "/bin/tar" (list "chfv" "-" filename))
+; )))
+;))))
+;
+;
+;;; copy in file to dest, validation is done BEFORE calling this
+;;;
+;(define (sretrieve:cp configdat retriever file comment)
+; (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
+; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
+; (datadir (conc base-dir "/" file))
+; (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+; (if (or (not base-dir)
+; (not (file-exists? base-dir)))
+; (begin
+; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+; (exit 1)))
+; (print datadir)
+; (if (not (file-exists? datadir))
+; (begin
+; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." )
+; (exit 1)))
+; (if (directory? datadir)
+; (begin
+; (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." )
+; (exit 1)))
+; (if(not (string-match (regexp allowed-sub-paths) file))
+; (begin
+; (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+; (exit 1)))
+;
+; (sretrieve:db-do
+; configdat
+; (lambda (db)
+; (sretrieve:register-action db "cp" retriever datadir comment)))
+; (sretrieve:do-as-calling-user
+; ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " )
+; (change-directory (pathname-directory datadir))
+; ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) )
+; (process-execute "/bin/tar" (list "chfv" "-" filename)))
+; ))
+;
+;;; ls in file to dest, validation is done BEFORE calling this
+;;;
+;(define (sretrieve:ls configdat retriever file comment)
+; (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
+; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
+; (datadir (conc base-dir "/" file))
+; (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+; (if (or (not base-dir)
+; (not (file-exists? base-dir)))
+; (begin
+; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+; (exit 1)))
+; (print datadir)
+; (if (not (file-exists? datadir))
+; (begin
+; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." )
+; (exit 1)))
+; (if(not (string-match (regexp allowed-sub-paths) file))
+; (begin
+; (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+; (exit 1)))
+;
+; (sretrieve:do-as-calling-user
+; (lambda ()
+; (process-execute "/bin/ls" (list "-ls" "-lrt" datadir ))
+; ))))
+
+
+
+(define (sretrieve:validate target-dir targ-mk)
+ (let* ((normal-path (normalize-pathname targ-mk))
+ (targ-path (conc target-dir "/" normal-path)))
+ (if (string-contains normal-path "..")
+ (begin
+ (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir )
+ (exit 1)))
+
+ (if (not (string-contains targ-path target-dir))
+ (begin
+ (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
+ (exit 1)))
+ (debug:print 0 "Path " targ-mk " is valid.")
+ ))
+
+
+;(define (sretrieve:backup-move path)
+; (let* ((trashdir (conc (pathname-directory path) "/.trash"))
+; (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+; (create-directory trashdir #t)
+; (if (directory? path)
+; (system (conc "mv " path " " trashfile))
+; (file-move path trash-file))))
+;
+;
+;(define (sretrieve:lst->path pathlst)
+; (conc "/" (string-intersperse (map conc pathlst) "/")))
+;
+;(define (sretrieve:path->lst path)
+; (string-split path "/"))
+;
+;(define (sretrieve:pathdat-apply-heuristics configdat path)
+; (cond
+; ((file-exists? path) "found")
+; (else (conc path " not installed"))))
+
+;;======================================================================
+;; MISC
+;;======================================================================
+
+(define (sretrieve:do-as-calling-user proc)
+ (let ((eid (current-effective-user-id))
+ (cid (current-user-id)))
+ (if (not (eq? eid cid)) ;; running suid
+ (set! (current-effective-user-id) cid))
+ ;; (debug:print 0 "running as " (current-effective-user-id))
+ (proc)
+ (if (not (eq? eid cid))
+ (set! (current-effective-user-id) eid))))
+
+(define (sretrieve:find name paths)
+ (if (null? paths)
+ #f
+ (let loop ((hed (car paths))
+ (tal (cdr paths)))
+ (if (file-exists? (conc hed "/" name))
+ hed
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal)))))))
+
+(define (sretrieve:stderr-print . args)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print args))))
+
+;;======================================================================
+;; SHELL
+;;======================================================================
+
+;; Create the sqlite db for shell
+;(define (sretrieve:shell-db-do path proc)
+; (if (not path)
+; (begin
+; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
+; (exit 1)))
+; (if (and path
+; (directory? path)
+; (file-read-access? path))
+; (let* ((dbpath (conc path "/" *exe-name* ".db"))
+; (writeable (file-write-access? dbpath))
+; (dbexists (file-exists? dbpath)))
+; (handle-exceptions
+; exn
+; (begin
+; (debug:print 2 "ERROR: problem accessing db " dbpath
+; ((condition-property-accessor 'exn 'message) exn))
+; (exit 1))
+; ;;(debug:print 0 "calling proc " proc "db path " dbpath )
+; (call-with-database
+; dbpath
+; (lambda (db)
+; ;;(debug:print 0 "calling proc " proc " on db " db)
+; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+; (if (not dbexists)(sretrieve:initialize-db db))
+; (proc db)))))
+; (debug:print 0 "ERROR: invalid path for storing database: " path)))
+
+
+
+;; function to find sheets to which use has access
+(define (sretrieve:has-permission area)
+ (let ((username (current-user-name)))
+ (cond
+ ((is-admin username)
+ #t)
+ ((is-user "retrieve" username area)
+ #t)
+ ((is-user "publish" username area)
+ #t)
+ ((is-user "writer-admin" username area)
+ #t)
+ ((is-user "read-admin" username area)
+ #t)
+ ((is-user "area-admin" username area)
+ #t)
+ (else
+ #f))))
+
+
+(define (sretrieve:get-accessable-projects area)
+ (let* ((projects `()))
+
+ (if (sretrieve:has-permission area)
+ (set! projects (cons area projects))
+ (begin
+ (sauth:print-error (conc "User cannot access area " area "!!"))
+ (exit 1)))
+ ; (print projects)
+ projects))
+
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+ (if (and (null? base-path-list) (equal? ext-path "") )
+ (print (string-intersperse top-areas " "))
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+ ;(print resolved-path)
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print (string-intersperse top-areas " "))
+ (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path)))
+ ;(print "Resolved path: " target-path)
+ (if (not (equal? target-path #f))
+ (begin
+ (if (symbolic-link? target-path)
+ (set! target-path (conc target-path "/")))
+ (if (not (equal? target-path #f))
+ (begin
+ (cond
+ ((null? tail-cmd-list)
+ (run (pipe
+ (ls "-lrt" ,target-path))))
+ ((not (equal? (car tail-cmd-list) "|"))
+ (print "ls cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
+ (else
+ (run (pipe
+ (ls "-lrt" ,target-path)
+ (begin (system (string-join (cdr tail-cmd-list))))))
+ ))))))))))))
+
+(define (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
+ (data "") )
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print "Path could not be resolved!!")
+ (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (or (not (file-exists? target-path)) (directory? target-path))
+ (print "Target path does not exist or is a directory!")
+ (begin
+ (cond
+ ((null? tail-cmd-list)
+ (run (pipe
+ (cat ,target-path))))
+ ((not (equal? (car tail-cmd-list) "|"))
+ (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
+ (else
+ (run (pipe
+ (cat ,target-path)
+ (begin (system (string-join (cdr tail-cmd-list))))))))))
+)))
+ (print "Path could not be resolved!!"))))
+
+(define (get-options cmd-list split-str)
+ (if (null? cmd-list)
+ (list '() '())
+ (let loop ((hed (car cmd-list))
+ (tal (cdr cmd-list))
+ (res '()))
+ (cond
+ ((equal? hed split-str)
+ (list res tal))
+ ((null? tal)
+ (list (cons hed res) tal))
+ (else
+ (loop (car tal)(cdr tal)(cons hed res)))))))
+
+
+(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
+ (pattern (car tail-cmd-list))
+ (pipe-cmd-list (get-options (cdr tail-cmd-list) "|"))
+ (options (string-join (car pipe-cmd-list)))
+ (pipe-cmd (cadr pipe-cmd-list))
+ (redirect-split (string-split (string-join tail-cmd-list) ">")) )
+ (if(and ( > (length redirect-split) 2 ))
+ (print "sgrep cmd cannot accept > " (string-join redirect-split) " as an argument!!" )
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print "Path could not be resolved!!")
+ (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))
+ (restrictions (if (equal? target-path #f)
+ ""
+ (sretrieve:shell-lookup base-path)))
+ (rest-str (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") ))))
+ (if (not (file-exists? target-path))
+ (print "Target path does not exist!")
+ (begin
+ (cond
+ ((and (null? pipe-cmd) (string-null? options))
+ (run (pipe
+ (grep ,pattern ,target-path ))))
+ ((and (null? pipe-cmd) (not (string-null? options)))
+ (run (pipe
+ (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))))))
+ ((and (not (null? pipe-cmd)) (string-null? options))
+ (run (pipe
+ (grep ,exclude-dir ,pattern ,target-path)
+ (begin (system (string-join pipe-cmd))))))
+ (else
+ (run (pipe
+ ;(grep ,options ,exclude-dir ,pattern ,target-path)
+ (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))
+
+ (begin (system (string-join pipe-cmd)))))))
+))))
+ (print "Path could not be resolved!!")))))
+
+
+(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path)
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )))
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print "Path could not be resolved!!")
+ (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (or (not (file-exists? target-path)) (directory? target-path))
+ (print "Target path does not exist or is a directory!")
+ (begin
+ ;(sretrieve:shell-db-do
+ ; db-location
+ ; (lambda (db)
+ ; (sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less " target-path))))
+
+ (setenv "LESSSECURE" "1")
+ (run (pipe
+ (less ,target-path))))))))
+ (print "Path could not be resolved!!"))))
+
+
+
+(define (sretrieve:shell-lookup base-path)
+ (let* ((usr (current-user-name))
+ (value (get-restrictions base-path usr)))
+ value))
+
+
+(define (sretrieve:load-shell-config fname)
+ (if (file-exists? fname)
+ (read-config fname #f #f)
+ ))
+
+
+(define (is_directory target-path)
+ (let* ((retval #f))
+ (sretrieve:do-as-calling-user
+ (lambda ()
+ ;(print (current-effective-user-id) )
+ (if (directory? target-path)
+ (set! retval #t))))
+ ;(print (current-effective-user-id))
+ retval))
+
+(define (make-exclude-pattern restriction-list )
+ (if (null? restriction-list)
+ ""
+ (let loop ((hed (car restriction-list))
+ (tal (cdr restriction-list))
+ (ret-str ""))
+ (cond
+ ((null? tal)
+ (conc ret-str ".+" hed ".*"))
+ (else
+ (loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|")))))) )
+
+(define (sretrieve:get-shell-cmd target-path base-path restrictions iport)
+ (if (not (file-exists? target-path))
+ (sauth:print-error "Target path does not exist!")
+ (begin
+ (if (not (equal? target-path #f))
+ (begin
+ (if (is_directory target-path)
+ (begin
+ (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe"))
+ (parent-dir target-path)
+ (last-dir-name (if (pathname-extension target-path)
+ (conc(pathname-file target-path) "." (pathname-extension target-path))
+ (pathname-file target-path)))
+ (curr-dir (current-directory))
+ (start-dir (conc (current-directory) "/" last-dir-name))
+ (execlude (make-exclude-pattern (string-split restrictions ","))))
+ ; (print tmpfile)
+ (if (file-exists? start-dir)
+ (begin
+ (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]")
+ (let* ((inl (read-line iport)))
+ (if (equal? inl "y")
+ (begin
+ (change-directory parent-dir)
+ (create-fifo tmpfile)
+ (process-fork
+ (lambda()
+ (sleep 1)
+ (with-output-to-file tmpfile
+ (lambda ()
+ (sretrieve:make_file parent-dir execlude parent-dir)))))
+
+ (run (pipe
+ (tar "chfv" "-" "-T" ,tmpfile )
+ (begin (system (conc "cd " start-dir ";tar xUf - " )))))
+ (change-directory curr-dir)
+ (system (conc "rm " tmpfile)) )
+ (begin
+ (print "Nothing has been retrieved!! ")))))
+ (begin
+ (sretrieve:do-as-calling-user
+ (lambda ()
+ (create-directory start-dir #t)))
+ (change-directory parent-dir)
+ ; (print execlude)
+ (create-fifo tmpfile)
+ (process-fork
+ (lambda()
+ (sleep 1)
+ (with-output-to-file tmpfile
+ (lambda ()
+ (sretrieve:make_file parent-dir execlude parent-dir)))))
+
+ (run (pipe
+ (tar "chfv" "-" "-T" ,tmpfile)
+ (begin (system (conc "cd " start-dir ";tar xUf - " )))))
+ (change-directory curr-dir)
+ (system (conc "rm " tmpfile))))))
+ (begin
+ (let*((parent-dir (pathname-directory target-path))
+ (start-dir (current-directory))
+ (filename (if (pathname-extension target-path)
+ (conc(pathname-file target-path) "." (pathname-extension target-path))
+ (pathname-file target-path)))
+ (work-dir-file (conc (current-directory) "/" filename)))
+ (if (file-exists? work-dir-file)
+ (begin
+ (print filename " already exist in your work dir. Do you want to over write it? [y|n]")
+ (let* ((inl (read-line iport)))
+ (if (equal? inl "y")
+ (begin
+ (change-directory parent-dir)
+ (run (pipe
+ (tar "chfv" "-" ,filename)
+ (begin (system (conc "cd " start-dir ";tar xUf - " )))))
+ (change-directory start-dir))
+ (begin
+ (print "Nothing has been retrieved!! ")))))
+ (begin
+ (change-directory parent-dir)
+ (run (pipe
+ (tar "chfv" "-" ,filename)
+ (begin (system (conc "cd " start-dir ";tar xUf -")))))
+ (change-directory start-dir)))))))))))
+
+(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)
+ (handle-exceptions
+ exn
+ (begin
+ (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: "
+ ((condition-property-accessor 'exn 'message) exn)))
+ (exit 1))
+
+ (if (not (file-exists? target-path))
+ (sauth:print-error "Error:Target path does not exist!")
+ (begin
+ (if (not (equal? target-path #f))
+ (begin
+ (if (is_directory target-path)
+ (begin
+ (let* ((parent-dir target-path)
+ (last-dir-name (if (pathname-extension target-path)
+ (conc(pathname-file target-path) "." (pathname-extension target-path))
+ (pathname-file target-path)))
+ (curr-dir (current-directory))
+ (start-dir (conc (current-directory) "/" last-dir-name))
+ (execlude (make-exclude-pattern (string-split restrictions ",")))
+ (tmpfile (conc "/tmp/my-pipe-" (current-process-id))))
+ (if (file-exists? start-dir)
+ (begin
+ (sauth:print-error (conclast-dir-name " already exist in your work dir."))
+ (sauth:print-error "Nothing has been retrieved!! "))
+ (begin
+ ; (sretrieve:do-as-calling-user
+ ; (lambda ()
+ ; (print tmpfile)
+ ;(if (not (file-exists? (conc "/tmp/" (current-user-name))))
+ ; (create-directory (conc "/tmp/" (current-user-name)) #t))
+ (change-directory parent-dir)
+ (create-fifo tmpfile)
+ (process-fork
+ (lambda()
+ (sleep 1)
+ (with-output-to-file tmpfile
+ (lambda ()
+ (sretrieve:make_file parent-dir execlude parent-dir)))))
+
+ (process-execute "/bin/tar" (append (list "chfv" "-" "-T" tmpfile) (list "--ignore-failed-read")))
+ ;(run (pipe
+ ;(tar "chfv" "-" "." )
+ ;(begin (system (conc "cd " start-dir ";tar xUf - " execlude )))))
+ (system (conc "rm " tmpfile))
+ (change-directory curr-dir)))))
+ (begin
+ (let*((parent-dir (pathname-directory target-path))
+ (start-dir (current-directory))
+ (filename (if (pathname-extension target-path)
+ (conc(pathname-file target-path) "." (pathname-extension target-path))
+ (pathname-file target-path)))
+ (work-dir-file (conc (current-directory) "/" filename)))
+ (if (file-exists? work-dir-file)
+ (begin
+ (print filename " already exist in your work dir.")
+ (print "Nothing has been retrieved!! "))
+ (begin
+ (change-directory parent-dir)
+ (process-execute "/bin/tar" (append (append (list "chfv" "-") (list filename)) (list "--ignore-failed-read")))
+ ;(run (pipe
+ ; (tar "chfv" "-" ,filename)
+ ; (begin (system (conc "cd " start-dir ";tar xUf -")))))
+ (change-directory start-dir))))))))))))
+
+(define (sretrieve:make_file path exclude base_path)
+ (find-files
+ path
+ action: (lambda (p res)
+ (cond
+ ((symbolic-link? p)
+ (if (directory?(read-symbolic-link p))
+ (sretrieve:make_file p exclude base_path)
+ (print (string-substitute (conc base_path "/") "" p "-"))))
+ ((directory? p)
+ ;;do nothing for dirs)
+ )
+ (else
+
+ (if (not (string-match (regexp exclude) p ))
+ (print (string-substitute (conc base_path "/") "" p "-"))))))
+ dotfiles: #t))
+
+(define (sretrieve:shell-help)
+(conc "Usage: " *exe-name* " [action [params ...]]
+
+ ls [target path] : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls | grep txt
+ cd : To change the current directory within the sretrive shell.
+ pwd : Prints the full pathname of the current directory within the sretrive shell.
+ get : download directory/files into the directory where sretrieve shell cmd was invoked
+ less : Read input file to allows backward movement in the file as well as forward movement
+ cat : show the contents of a file. The output of the cmd can be piped into other system cmd.
+
+ sgrep [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd.
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)
+)
+;(define (toplevel-command . args) #f)
+(define (sretrieve:shell area)
+ ; (print area)
+ (use readline)
+ (let* ((path '())
+ (prompt "sretrieve> ")
+ (args (argv))
+ (usr (current-user-name) )
+ (top-areas (sretrieve:get-accessable-projects area))
+ (close-port #f)
+ (area-obj (get-obj-by-code area))
+ (user-obj (get-user usr))
+ (base-path (if (null? area-obj)
+ ""
+ (caddr (cdr area-obj))))
+ (iport (make-readline-port prompt)))
+ (if (null? area-obj)
+ (begin
+ (print "Area " area " does not exist")
+ (exit 1)))
+ (let loop ((inl (read-line iport)))
+ ;(print 1)
+ (if (not (or (or (eof-object? inl)
+ (equal? inl "exit")) (port-closed? iport)))
+ (let* ((parts (string-split inl))
+ (cmd (if (null? parts) #f (car parts))))
+ ; (print "2")
+ (if (and (not cmd) (not (port-closed? iport)))
+ (loop (read-line))
+ (case (string->symbol cmd)
+ ((cd)
+ (if (> (length parts) 1) ;; have a parameter
+ (begin
+ (let*((arg (cadr parts))
+ (resolved-path (sauth-common:resolve-path arg path top-areas))
+ (target-path (sauth-common:get-target-path path arg top-areas base-path)))
+ (if (not (equal? target-path #f))
+ (if (or (equal? resolved-path #f) (not (file-exists? target-path)))
+ (print "Invalid argument " arg ".. ")
+ (begin
+ (set! path resolved-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd"))))
+ )))))
+ (set! path '())))
+ ((pwd)
+ (if (null? path)
+ (print "/")
+ (print "/" (string-join path "/"))))
+ ((ls)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (sauth-common:shell-ls-cmd path "" top-areas base-path '())
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) )
+ ((< plen 2)
+
+ (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '())
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))
+ (else
+ (if (equal? (car thepath) "|")
+ (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
+ (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))
+ ((cat)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (print "Error: Missing argument to cat"))
+ ((< plen 2)
+ (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path '())
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat")))))
+
+ (else
+ (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path (cdr thepath))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat"))))
+))))
+ ((sgrep)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (print "Error: Missing arguments to grep!! Useage: grep [options] "))
+ ((< plen 2)
+ (print "Error: Missing arguments to grep!! Useage: grep [options] "))
+ (else
+ (sretrieve:shell-grep-cmd path (car thepath) top-areas base-path (cdr thepath))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "grep"))))))))
+
+ ((less)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (print "Error: Missing argument to less"))
+ ((< plen 2)
+ (sretrieve:shell-less-cmd path (car thepath) top-areas base-path)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "less")))))
+ (else
+ (print "less cmd takes only one () argument!!")))))
+ ((get)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ `()))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (print "Error: Missing argument to get"))
+ ((< plen 2)
+ (let* ((target-path (sauth-common:get-target-path path (car thepath) top-areas base-path))
+ (restrictions (if (equal? target-path #f)
+ ""
+ (sretrieve:shell-lookup base-path))))
+ (if (not (equal? target-path #f))
+ (begin
+ (sretrieve:get-shell-cmd target-path base-path restrictions iport)
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "get"))))))))
+ (else
+ (print "Error: get cmd takes only one argument ")))))
+ ((exit)
+ (print "got exit"))
+ ((help)
+ (print (sretrieve:shell-help)))
+ (else
+ (print "Got command: " inl))))
+ (loop (read-line iport)))))))
+;;))
+
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+;;(define *default-log-port* (current-error-port))
+
+;(define (sretrieve:load-config exe-dir exe-name)
+; (let* ((fname (conc exe-dir "/." exe-name ".config")))
+; ;; (ini:property-separator-patt " * *")
+; ;; (ini:property-separator #\space)
+; (if (file-exists? fname)
+; ;; (ini:read-ini fname)
+; (read-config fname #f #f)
+; (make-hash-table))))
+
+;; package-type is "megatest", "builds", "kits" etc.
+;;
+
+;(define (sretrieve:load-packages configdat exe-dir package-type)
+; (push-directory exe-dir)
+; (let* ((packages-metadir (configf:lookup configdat "settings" "packages-metadir"))
+; (conversion-script (configf:lookup configdat "settings" "conversion-script"))
+; (upstream-file (configf:lookup configdat "settings" "upstream-file"))
+; (package-config (conc packages-metadir "/" package-type ".config")))
+; (if (file-exists? upstream-file)
+; (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
+; (> (file-modification-time upstream-file)(file-modification-time package-config)))
+; (handle-exceptions
+; exn
+; (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
+; (let ((pid (process-run conversion-script (list upstream-file package-config))))
+; (process-wait pid)))
+; (debug:print 0 "Skipping update of " package-config " from " upstream-file))
+; (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found"))
+; (let ((res (if (file-exists? package-config)
+; (begin
+; (debug:print 0 "Reading package config " package-config)
+; (read-config package-config #f #t))
+; (make-hash-table))))
+; (pop-directory)
+; res)))
+
+(define (toplevel-command . args) #f)
+(define (sretrieve:process-action action . args)
+ ; (print action)
+ ; (use readline)
+ (case (string->symbol action)
+ ((get)
+ (if (< (length args) 2)
+ (begin
+ (sauth:print-error "Missing arguments; " )
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0))
+ (iport (make-readline-port ">"))
+ (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))))
+ (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:get-shell-cmd-line target-path base-path restrictions iport))))))
+ ((cp)
+ (if (< (length args) 2)
+ (begin
+ (sauth:print-error "Missing arguments; " )
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0))
+ (iport (make-readline-port ">"))
+ (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))))
+ ; (print args)
+ (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))))
+ ;(print target-path)
+ (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: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; ")
+ (exit 1)))
+ ((equal? (length args) 1)
+ (let* ((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)))))
+ (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)
+ (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0))
+ (usr (current-user-name))
+ (user-obj (get-user usr))
+ (area (car args)))
+ (let* ((area-obj (get-obj-by-code area))
+ (top-areas (sretrieve:get-accessable-projects area))
+ (base-path (if (null? area-obj)
+ ""
+ (caddr (cdr area-obj))))
+
+ (sub-path (if (null? remargs)
+ area
+ (conc area "/" (car remargs)))))
+ ;(print "sub path " sub-path)
+ (if (null? area-obj)
+ (begin
+ (print "Area " area " does not exist")
+ (exit 1)))
+ (sauth-common:shell-ls-cmd `() sub-path top-areas base-path '())
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))))
+
+ ((shell)
+ (if (< (length args) 1)
+ (begin
+ (print "ERROR: Missing arguments !!" )
+ (exit 1))
+ (sretrieve:shell (car args))))
+ (else (print 0 "Unrecognised command " action))))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (exe-name (pathname-file (car (argv))))
+ ;(exe-dir (or (pathname-directory prog)
+ ; (sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":"))))
+ ;(configdat (sretrieve:load-config exe-dir exe-name))
+)
+ ;; preserve the exe data in the config file
+ ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name)
+ ; (list "exe-dir" exe-dir)))
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print sretrieve:help))
+ (else
+ (print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
+ ;; multi-word commands
+ ((null? rema)(print sretrieve:help))
+ ((>= (length rema) 2)
+
+ (apply sretrieve:process-action (car rema) (cdr rema)))
+ (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))
+
+(main)
+
+
+
DELETED sauthorize.scm
Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ /dev/null
@@ -1,651 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-;;
-
-(use defstruct)
-(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 margs))
-
-(include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
-;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
-(include "sauth-paths.scm")
-(include "sauth-common.scm")
-
-;;
-;; GLOBALS
-;;
-(define *verbosity* 1)
-(define *logging* #f)
-(define *exe-name* (pathname-file (car (argv))))
-(define *sretrieve:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
-
- list : list areas $USER's can access
- log : get listing of recent activity.
- sauth list-area-user : list the users that can access the area.
- sauth open --group : Open up an area. User needs to be the owner of the area to open it.
- --code
- --retrieve|--publish [--additional-grps ]
- sauth update --retrieve|--publish : update the binaries with the lates changes
- sauth grant --area : Grant permission to read or write to a area that is alrady opend up.
- --expiration yyyy/mm/dd --retrieve|--publish
- [--restrict ]
- sauth read-shell : Open sretrieve shell for reading.
- sauth write-shell : Open spublish shell for writing.
-
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-;; replace (strftime('%s','now')), with datetime('now'))
-(define (sauthorize:initialize-db db)
- (for-each
- (lambda (qry)
- (exec (sql db qry)))
- (list
- "CREATE TABLE IF NOT EXISTS actions
- (id INTEGER PRIMARY KEY,
- cmd TEXT NOT NULL,
- user_id INTEGER NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
- area_id INTEGER NOT NULL,
- comment TEXT DEFAULT '' NOT NULL,
- action_type TEXT NOT NULL);"
- "CREATE TABLE IF NOT EXISTS users
- (id INTEGER PRIMARY KEY,
- username TEXT NOT NULL,
- is_admin TEXT NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
- );"
- "CREATE TABLE IF NOT EXISTS areas
- (id INTEGER PRIMARY KEY,
- basepath TEXT NOT NULL,
- code TEXT NOT NULL,
- exe_name TEXT NOT NULL,
- required_grps TEXT DEFAULT '' NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
- );"
- "CREATE TABLE IF NOT EXISTS permissions
- (id INTEGER PRIMARY KEY,
- access_type TEXT NOT NULL,
- user_id INTEGER NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
- area_id INTEGER NOT NULL,
- restriction TEXT DEFAULT '' NOT NULL,
- expiration TIMESTAMP DEFAULT NULL);"
- )))
-
-
-
-
-(define (get-access-type args)
- (let loop ((hed (car args))
- (tal (cdr args)))
- (cond
- ((equal? hed "--retrieve")
- "retrieve")
- ((equal? hed "--publish")
- "publish")
- ((equal? hed "--area-admin")
- "area-admin")
- ((equal? hed "--writer-admin")
- "writer-admin")
- ((equal? hed "--read-admin")
- "read-admin")
-
- ((null? tal)
- #f)
- (else
- (loop (car tal)(cdr tal))))))
-
-
-
-;; check if user can gran access to an area
-(define (can-grant-perm username access-type area)
- (let* ((isadmin (is-admin username))
- (is-area-admin (is-user "area-admin" username area ))
- (is-read-admin (is-user "read-admin" username area) )
- (is-writer-admin (is-user "writer-admin" username area) ) )
- (cond
- ((equal? isadmin #t)
- #t)
- ((equal? is-area-admin #t )
- #t)
- ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
- #t)
- ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
- #t)
-
- (else
- #f))))
-
-(define (sauthorize:list-areausers area )
- (sauthorize:db-do (lambda (db)
- (print "Users having access to " area ":")
- (query (for-each-row
- (lambda (row)
- (let* ((exp-date (cadr row)))
- (if (is-access-valid exp-date)
- (apply print (intersperse row " | "))))))
- (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
-
-
-
-
-; check if executable exists
-(define (exe-exist exe access-type)
- (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
- ; (print filepath)
- (if (file-exists? filepath)
- #t
- #f)))
-
-(define (copy-exe access-type exe-name group)
- (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
- (let* ((spath (conc *exe-src* "/s" access-type))
- (dpath (conc *exe-path* "/" access-type "/" exe-name)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd "/bin/cp" (list spath dpath ))
- (if (equal? access-type "publish")
- (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
- (begin
- (if (equal? group "none")
- (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
- (begin
- (run-cmd "/bin/chgrp" (list group dpath))
- (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
- (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
-
-(define (get-exe-name path group)
- (let ((name ""))
- (sauthorize:do-as-calling-user
- (lambda ()
- (if (equal? (current-effective-user-id) (file-owner path))
- (set! name (conc (current-user-name) "_" group))
- (begin
- (print "You cannot open areas that you dont own!!")
- (exit 1)))))
-name))
-
-(define (sauthorize:valid-unix-user username)
- (let* ((ret-val #f))
- (let-values (((inp oup pid)
- (process "/usr/bin/id" (list username))))
- (let loop ((inl (read-line inp)))
- (if (string? inl)
- (if (string-contains inl "No such user")
- (set! ret-val #f)
- (set! ret-val #t)))
- (if (eof-object? inl)
- (begin
- (close-input-port inp)
- (close-output-port oup))
- (loop (read-line inp)))))
- ret-val))
-
-
-;check if a paths/codes are vaid and if area is alrady open
-(define (open-area group path code access-type other-grps)
- (let* ((exe-name (get-exe-name path group))
- (path-obj (get-obj-by-path path))
- (code-obj (get-obj-by-code-no-grp-validation code)))
- ;(print path-obj)
- (cond
- ((not (null? path-obj))
- (if (equal? code (car path-obj))
- (begin
- (if (equal? exe-name (cadr path-obj))
- (begin
- (if (not (exe-exist exe-name access-type))
- (copy-exe access-type exe-name group)
- (begin
- (print "Area already open!!")
- (exit 1))))
- (begin
- (if (not (exe-exist exe-name access-type))
- (copy-exe access-type exe-name group))
- ;; update exe-name in db
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
- )))
- (begin
- (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
- (exit 1))))
-
- ((not (null? code-obj))
- (print "Code " code " is used for diffrent path. Please try diffrent value of --code" )
- (exit 1))
- (else
- ; (print (exe-exist exe-name access-type))
- (if (not (exe-exist exe-name access-type))
- (copy-exe access-type exe-name group))
- (sauthorize:db-do (lambda (db)
- (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ")
- (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
-
-(define (user-has-open-perm user path access)
- (let* ((has-access #f)
- (eid (current-user-id)))
- (cond
- ((is-admin user)
- (set! has-access #t ))
- ((and (is-read-admin user) (equal? access "retrieve"))
- (set! has-access #t ))
- (else
- (print "User " user " does not have permission to open areas")))
- has-access))
-
-
-;;check if user has group access
-(define (is-group-washed req_grpid current-grp-list)
- (let loop ((hed (car current-grp-list))
- (tal (cdr current-grp-list)))
- (cond
- ((equal? hed req_grpid)
- #t)
- ((null? tal)
- #f)
- (else
- (loop (car tal)(cdr tal))))))
-
-;create executables with appropriate suids
-(define (sauthorize:open user path group code access-type other-groups)
- (let* ((gpid (group-information group))
- (req_grpid (if (equal? group "none")
- group
- (if (equal? gpid #f)
- #f
- (caddr gpid))))
- (current-grp-list (get-groups))
- (valid-grp (if (equal? group "none")
- group
- (is-group-washed req_grpid current-grp-list))))
- (if (and (not (equal? group "none")) (equal? valid-grp #f ))
- (begin
- (print "Group " group " is not washed in the current xterm!!")
- (exit 1))))
- (if (not (file-write-access? path))
- (begin
- (print "You can open areas owned by yourself. You do not have permissions to open path." path)
- (exit 1)))
- (if (user-has-open-perm user path access-type)
- (begin
- ;(print "here")
- (open-area group path code access-type other-groups)
- (sauthorize:grant user user code "2017/12/25" "read-admin" "")
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
- (print "Area has " path " been opened for " access-type ))))
-
-(define (sauthorize:update username exe area access-type)
- (let* ((parts (string-split exe "_"))
- (owner (car parts))
- (group (cadr parts))
- (gpid (group-information group))
- (req_grpid (if (equal? group "none")
- group
- (if (equal? gpid #f)
- #f
- (caddr gpid))))
-
- (current-grp-list (get-groups))
- (valid-grp (if (equal? group "none")
- group
- (is-group-washed req_grpid current-grp-list))))
- (if (not (equal? username owner))
- (begin
- (print "You cannot update " area ". Only " owner " can update this area!!")
- (exit 1)))
- (copy-exe access-type exe group)
- (print "recording action..")
- (sauthorize:db-do (lambda (db)
-
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
- (print "Area has " area " been update!!" )))
-
-(define (sauthorize:grant auser guser area exp-date access-type restrict)
- ; check if user exist in db
- (let* ((area-obj (get-area area))
- (auser-obj (get-user auser))
- (user-obj (get-user guser)))
-
- (if (null? user-obj)
- (begin
- ;; is guser a valid unix user
- (if (not (sauthorize:valid-unix-user guser))
- (begin
- (print "User " guser " is Invalid unix user!!")
- (exit 1)))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
- (set! user-obj (get-user guser))))
- (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
- (if(null? perm-obj)
- (begin
- ;; insert permissions
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
- (begin
- ;update permissions
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))
- (print "Permission has been sucessfully granted to user " guser))))
-
-(define (sauthorize:process-action username action . args)
- (case (string->symbol action)
- ((grant)
- (if (< (length args) 6)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
- (guser (car args))
- (restrict (or (args:get-arg "--restrict") ""))
- (area (or (args:get-arg "--area") ""))
- (exp-date (or (args:get-arg "--expiration") ""))
- (access-type (get-access-type remargs)))
- ; (print "version " guser " restrict " restrict )
- ; (print "area " area " exp-date " exp-date " access-type " access-type)
- (cond
- ((equal? guser "")
- (print "Username not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? area "")
- (print "Area not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? access-type #f)
- (print "Access type not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? exp-date "")
- (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
- (exit 1)))
- (if (not (area-exists area))
- (begin
- (print "Area does not exisit!!")
- (exit 1)))
- (if (can-grant-perm username access-type area)
- (begin
- (print "calling sauthorize:grant ")
- (sauthorize:grant username guser area exp-date access-type restrict))
- (begin
- (print "User " username " does not have permission to grant permissions to area " area "!!")
- (exit 1)))))
- ((list-area-user)
- (if (not (equal? (length args) 1))
- (begin
- (print "Missing argument area code to list-area-user ")
- (exit 1)))
- (let* ((area (car args)))
- (if (not (area-exists area))
- (begin
- (print "Area does not exisit!!")
- (exit 1)))
-
- (sauthorize:list-areausers area )
- ))
- ((read-shell)
- (if (not (equal? (length args) 1))
- (begin
- (print "Missing argument area code to read-shell ")
- (exit 1)))
- (let* ((area (car args))
- (code-obj (get-obj-by-code area)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "retrieve")))
- (begin
- (print "Area " area " is not open for reading!!")
- (exit 1)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
- ((write-shell)
- (if (not (equal? (length args) 1))
- (begin
- (print "Missing argument area code to read-shell ")
- (exit 1)))
- (let* ((area (car args))
- (code-obj (get-obj-by-code area)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "publish")))
- (begin
- (print "Area " area " is not open for Writing!!")
- (exit 1)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
- ((publish)
- (if (< (length args) 2)
- (begin
- (print "Missing argument to publish. \n publish [opts] ")
- (exit 1)))
-
- (let* ((action (car args))
- (area (cadr args))
- (cmd-args (cddr args))
- (code-obj (get-obj-by-code area)))
- ;(print "area " area)
- ;(print "code: " code-obj)
- ;(print (exe-exist (cadr code-obj) "publish"))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "publish")))
- (begin
- (print "Area " area " is not open for writing!!")
- (exit 1)))
- ;(print "hear")
- (sauthorize:do-as-calling-user
- (lambda ()
- ; (print *exe-path* "/publish/" (cadr code-obj) action area cmd-args )
- (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
-
- ((retrieve)
- (if (< (length args) 2)
- (begin
- (print "Missing argument to publish. \n publish [opts] ")
- (exit 1)))
- (let* ((action (car args))
- (area (cadr args))
- (cmd-args (cddr args))
- (code-obj (get-obj-by-code area)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "retrieve")))
- (begin
- (print "Area " area " is not open for reading!!")
- (exit 1)))
- ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
-
-
-
- ((open)
- (if (< (length args) 6)
- (begin
- (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open --group --code --retrieve|--publish")
- (exit 1)))
- (let* ((remargs (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
- (path (car args))
- (group (or (args:get-arg "--group") ""))
- (area (or (args:get-arg "--code") ""))
- (other-grps (or (args:get-arg "--additional-grps") ""))
- (access-type (get-access-type remargs)))
-
- (cond
- ((equal? path "")
- (print "path not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? area "")
- (print "--code not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? access-type #f)
- (print "Access type not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((and (not (equal? access-type "publish"))
- (not (equal? access-type "retrieve")))
- (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
- (exit 1)))
- ; (print other-grps)
- (sauthorize:open username path group area access-type other-grps)))
- ((update)
- (if (< (length args) 2)
- (begin
- (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update --retrieve|--publish")
- (exit 1)))
- (let* ((area (car args))
- (code-obj (get-obj-by-code area))
- (access-type (get-access-type (cdr args))))
- (if (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
- (begin
- (print "Access type can be --retrieve|--publish ")
- (exit 1)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) access-type)))
- (begin
- (print "Area " area " is not open for reading!!")
- (exit 1)))
- (sauthorize:update username (cadr code-obj) area access-type )))
- ((area-admin)
- (let* ((usr (car args))
- (usr-obj (get-user usr))
- (user-id (car (get-user username))))
-
- (if (is-admin username)
- (begin
- ; (print usr-obj)
- (if (null? usr-obj)
- (begin
- (sauthorize:db-do (lambda (db)
- ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
- (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
- (begin
- ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
- (print "User " usr " is updated with area-admin access!"))
- (print "Admin only function"))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" ))))))
- ((mk-admin)
- (let* ((usr (car args))
- (usr-obj (get-user usr))
- (user-id (car (get-user username))))
- (if (not (sauthorize:valid-unix-user usr))
- (begin
- (print "User " usr " is Invalid unix user!!")
- (exit 1)))
-
- (if (member username *super-users*)
- (begin
- (if (null? usr-obj)
- (begin
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
- (begin
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
- (print "User " usr " is updated with admin access!"))
- (print "Super-Admin only function"))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" ))))))
-
- ((register-log)
- (if (< (length args) 4)
- (print "Invalid arguments"))
- ;(print args)
- (let* ((cmd-line (car args))
- (user-id (cadr args))
- (area-id (caddr args))
- (user-obj (get-user username))
- (cmd (cadddr args)))
-
- (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
- (begin
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
- (print "You ar not authorised to run this cmd")
-
-)))
-
-
- (else (print 0 "Unrecognised command " action))))
-
-(define (main)
- (let* ((args (argv))
- (prog (car args))
- (rema (cdr args))
- (username (current-user-name)))
- ;; preserve the exe data in the config file
- (cond
- ;; one-word commands
- ((eq? (length rema) 1)
- (case (string->symbol (car rema))
- ((help -h -help --h --help)
- (print sauthorize:help))
- ((list)
-
- (sauthorize:db-do (lambda (db)
- (print "My Area accesses: ")
- (query (for-each-row
- (lambda (row)
- (let* ((exp-date (car row)))
- (if (is-access-valid exp-date)
- (apply print (intersperse (cdr row) " | "))))))
- (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
-
- ((log)
- (sauthorize:db-do (lambda (db)
- (print "Logs : ")
- (query (for-each-row
- (lambda (row)
-
- (apply print (intersperse row " | "))))
- (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
- (else
- (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
- ;; multi-word commands
- ((null? rema)(print sauthorize:help))
- ((>= (length rema) 2)
- (apply sauthorize:process-action username (car rema)(cdr rema)))
- (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
-
-(main)
-
-
-
DELETED spublish.scm
Index: spublish.scm
==================================================================
--- spublish.scm
+++ /dev/null
@@ -1,820 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-(use defstruct)
-(use scsh-process)
-(use refdb)
-(use srfi-18)
-(use srfi-19)
-(use format)
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
-
-;(declare (uses configf))
-;; (declare (uses tree))
-(declare (uses margs))
-
-(include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
-;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
-(include "sauth-paths.scm")
-(include "sauth-common.scm")
-(define (toplevel-command . args) #f)
-(use readline)
-
-;;
-;; GLOBALS
-;;
-(define *spublish:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define spublish:help (conc "Usage: spublish [action [params ...]]
-
- ls : list contents of target area
- cp|publish : copy file to target area
- mkdir : maks directory in target area
- rm : remove file from target area
- ln : creates a symlink
-
- options:
-
- -m \"message\" : describe what was done
-Note: All the target locations relative to base path
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-(define *default-log-port* (current-error-port))
-(define *verbosity* 1)
-
-;(define (spublish:initialize-db db)
-; (for-each
-; (lambda (qry)
-; (exec (sql db qry)))
-; (list
-; "CREATE TABLE IF NOT EXISTS actions
-; (id INTEGER PRIMARY KEY,
-; action TEXT NOT NULL,
-; submitter TEXT NOT NULL,
-; datetime TIMESTAMP DEFAULT (strftime('%s','now')),
-; srcpath TEXT NOT NULL,
-; comment TEXT DEFAULT '' NOT NULL,
-; state TEXT DEFAULT 'new');"
-; )))
-
-;(define (spublish:register-action db action submitter source-path comment)
-; (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment)
-; VALUES(?,?,?,?)")
-; action
-; submitter
-; source-path
-; comment))
-
-;; (call-with-database
-;; (lambda (db)
-;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
-;; ...))
-
-;; Create the sqlite db
-;(define (spublish:db-do configdat proc)
-; (let ((path (configf:lookup configdat "database" "location")))
-; (if (not path)
-; (begin
-; (print "[database]\nlocation /some/path\n\n Is missing from the config file!")
-; (exit 1)))
-; (if (and path
-; (directory? path)
-; (file-read-access? path))
-; (let* ((dbpath (conc path "/spublish.db"))
-; (writeable (file-write-access? dbpath))
-; (dbexists (file-exists? dbpath)))
-; (handle-exceptions
-; exn
-; (begin
-; (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
-; ((condition-property-accessor 'exn 'message) exn))
-; (exit 1))
-; (call-with-database
-; dbpath
-; (lambda (db)
-; ;; (print "calling proc " proc " on db " db)
-; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-; (if (not dbexists)(spublish:initialize-db db))
-; (proc db)))))
-; (print "ERROR: invalid path for storing database: " path))))
-;
-;;; copy in file to dest, validation is done BEFORE calling this
-;;;
-;(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment)
-; (let ((dest-dir-path (conc target-dir "/" dest-dir))
-; (targ-path (conc target-dir "/" dest-dir "/" targ-file)))
-; (if (file-exists? targ-path)
-; (begin
-; (print "ERROR: target file already exists, remove it before re-publishing")
-; (exit 1)))
-; (if (not(file-exists? dest-dir-path))
-; (begin
-; (print "ERROR: target directory " dest-dir-path " does not exists." )
-; (exit 1)))
-;
-; (spublish:db-do
-; configdat
-; (lambda (db)
-; (spublish:register-action db "cp" submitter source-path comment)))
-; (let* (;; (target-path (configf:lookup "settings" "target-path"))
-; (th1 (make-thread
-; (lambda ()
-; (file-copy source-path targ-path #t))
-; (print " ... file " targ-path " copied to " targ-path)
-; ;; (let ((pid (process-run "cp" (list source-path target-dir))))
-; ;; (process-wait pid)))
-; "copy thread"))
-; (th2 (make-thread
-; (lambda ()
-; (let loop ()
-; (thread-sleep! 15)
-; (display ".")
-; (flush-output)
-; (loop)))
-; "action is happening thread")))
-; (thread-start! th1)
-; (thread-start! th2)
-; (thread-join! th1))
-; (cons #t "Successfully saved data")))
-;
-;;; copy directory to dest, validation is done BEFORE calling this
-;;;
-;
-;(define (spublish:tar configdat submitter target-dir dest-dir comment)
-; (let ((dest-dir-path (conc target-dir "/" dest-dir)))
-; (if (not(file-exists? dest-dir-path))
-; (begin
-; (print "ERROR: target directory " dest-dir-path " does not exists." )
-; (exit 1)))
-; ;;(print dest-dir-path )
-; (spublish:db-do
-; configdat
-; (lambda (db)
-; (spublish:register-action db "tar" submitter dest-dir-path comment)))
-; (change-directory dest-dir-path)
-; (process-wait (process-run "/bin/tar" (list "xf" "-")))
-; (print "Data copied to " dest-dir-path)
-;
-; (cons #t "Successfully saved data")))
-
-
-;(define (spublish:validate target-dir targ-mk)
-; (let* ((normal-path (normalize-pathname targ-mk))
-; (targ-path (conc target-dir "/" normal-path)))
-; (if (string-contains normal-path "..")
-; (begin
-; (print "ERROR: Path " targ-mk " resolved outside target area " target-dir )
-; (exit 1)))
-;
-; (if (not (string-contains targ-path target-dir))
-; (begin
-; (print "ERROR: You cannot update data outside " target-dir ".")
-; (exit 1)))
-; (print "Path " targ-mk " is valid.")
-; ))
-;; make directory in dest
-;;
-
-;(define (spublish:mkdir configdat submitter target-dir targ-mk comment)
-; (let ((targ-path (conc target-dir "/" targ-mk)))
-;
-; (if (file-exists? targ-path)
-; (begin
-; (print "ERROR: target Directory " targ-path " already exist!!")
-; (exit 1)))
-; (spublish:db-do
-; configdat
-; (lambda (db)
-; (spublish:register-action db "mkdir" submitter targ-mk comment)))
-; (let* ((th1 (make-thread
-; (lambda ()
-; (create-directory targ-path #t)
-; (print " ... dir " targ-path " created"))
-; "mkdir thread"))
-; (th2 (make-thread
-; (lambda ()
-; (let loop ()
-; (thread-sleep! 15)
-; (display ".")
-; (flush-output)
-; (loop)))
-; "action is happening thread")))
-; (thread-start! th1)
-; (thread-start! th2)
-; (thread-join! th1))
-; (cons #t "Successfully saved data")))
-
-;; create a symlink in dest
-;;
-;(define (spublish:ln configdat submitter target-dir targ-link link-name comment)
-; (let ((targ-path (conc target-dir "/" link-name)))
-; (if (file-exists? targ-path)
-; (begin
-; (print "ERROR: target file " targ-path " already exist!!")
-; (exit 1)))
-; (if (not (file-exists? targ-link ))
-; (begin
-; (print "ERROR: target file " targ-link " does not exist!!")
-; (exit 1)))
-;
-; (spublish:db-do
-; configdat
-; (lambda (db)
-; (spublish:register-action db "ln" submitter link-name comment)))
-; (let* ((th1 (make-thread
-; (lambda ()
-; (create-symbolic-link targ-link targ-path )
-; (print " ... link " targ-path " created"))
-; "symlink thread"))
-; (th2 (make-thread
-; (lambda ()
-; (let loop ()
-; (thread-sleep! 15)
-; (display ".")
-; (flush-output)
-; (loop)))
-; "action is happening thread")))
-; (thread-start! th1)
-; (thread-start! th2)
-; (thread-join! th1))
-; (cons #t "Successfully saved data")))
-
-
-;; remove copy of file in dest
-;;
-;(define (spublish:rm configdat submitter target-dir targ-file comment)
-; (let ((targ-path (conc target-dir "/" targ-file)))
-; (if (not (file-exists? targ-path))
-; (begin
-; (print "ERROR: target file " targ-path " not found, nothing to remove.")
-; (exit 1)))
-; (spublish:db-do
-; configdat
-; (lambda (db)
-; (spublish:register-action db "rm" submitter targ-file comment)))
-; (let* ((th1 (make-thread
-; (lambda ()
-; (delete-file targ-path)
-; (print " ... file " targ-path " removed"))
-; "rm thread"))
-; (th2 (make-thread
-; (lambda ()
-; (let loop ()
-; (thread-sleep! 15)
-; (display ".")
-; (flush-output)
-; (loop)))
-; "action is happening thread")))
-; (thread-start! th1)
-; (thread-start! th2)
-; (thread-join! th1))
-; (cons #t "Successfully saved data")))
-
-(define (spublish:backup-move path)
- (let* ((trashdir (conc (pathname-directory path) "/.trash"))
- (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
- (create-directory trashdir #t)
- (if (directory? path)
- (system (conc "mv " path " " trashfile))
- (file-move path trash-file))))
-
-
-(define (spublish:lst->path pathlst)
- (conc "/" (string-intersperse (map conc pathlst) "/")))
-
-(define (spublish:path->lst path)
- (string-split path "/"))
-
-(define (spublish:pathdat-apply-heuristics configdat path)
- (cond
- ((file-exists? path) "found")
- (else (conc path " not installed"))))
-
-;;======================================================================
-;; MISC
-;;======================================================================
-
-;(define (spublish:do-as-calling-user proc)
-; (let ((eid (current-effective-user-id))
-; (cid (current-user-id)))
-; (if (not (eq? eid cid)) ;; running suid
-; (set! (current-effective-user-id) cid))
-; ;; (print "running as " (current-effective-user-id))
-; (proc)
-; (if (not (eq? eid cid))
-; (set! (current-effective-user-id) eid))))
-
-;(define (spublish:find name paths)
-; (if (null? paths)
-; #f
-; (let loop ((hed (car paths))
-; (tal (cdr paths)))
-; (if (file-exists? (conc hed "/" name))
-; hed
-; (if (null? tal)
-; #f
-; (loop (car tal)(cdr tal)))))))
-
-;;========================================================================
-;;Shell
-;;========================================================================
-(define (spublish:get-accessable-projects area)
- (let* ((projects `()))
- (if (spublish:has-permission area)
- (set! projects (cons area projects))
- (begin
- (print "User cannot access area " area "!!")
- (exit 1)))
- projects))
-
-;; function to find sheets to which use has access
-(define (spublish:has-permission area)
- ;(print "in spublish:has-permission")
- (let* ((username (current-user-name))
- (ret-val #f))
- (cond
- ((equal? (is-admin username) #t)
- (set! ret-val #t))
- ((equal? (is-user "publish" username area) #t)
- (set! ret-val #t))
- ((equal? (is-user "writer-admin" username area) #t)
- (set! ret-val #t))
-
- ((equal? (is-user "area-admin" username area) #t)
- (set! ret-val #t))
- (else
- (set! ret-val #f)))
- ret-val))
-
-(define (is_directory target-path)
- (let* ((retval #f))
- (sauthorize:do-as-calling-user
- (lambda ()
- ;(print (current-effective-user-id) )
- (if (directory? target-path)
- (set! retval #t))))
- ;(print (current-effective-user-id))
- retval))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; shell functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (spublish:shell-cp src-path target-path)
- (cond
- ((not (file-exists? target-path))
- (sauth:print-error (conc " target Directory " target-path " does not exist!!")))
- ((not (file-exists? src-path))
- (sauth:print-error (conc "Source path " src-path " does not exist!!" )))
- (else
- (if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
- (begin
- (sauth:print-error "Destination does not have enough disk space.")
- (exit 1)))
- (if (is_directory src-path)
- (begin
- (let* ((parent-dir src-path)
- (start-dir target-path))
- (run (pipe
- (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
- (begin (change-directory start-dir)
- ;(print "123")
- (run-cmd "tar" (list "xf" "-")))))
- (print "Copied data to " start-dir)))
- (begin
- (let*((parent-dir (pathname-directory src-path))
- (start-dir target-path)
- (filename (if (pathname-extension src-path)
- (conc(pathname-file src-path) "." (pathname-extension src-path))
- (pathname-file src-path))))
- ;(print "parent-dir " parent-dir " start-dir " start-dir)
- (run (pipe
- (begin (system (conc "cd " parent-dir ";tar chf - " filename )))
- (begin (change-directory start-dir)
- (run-cmd "tar" (list "xf" "-")))))
- (print "Copied data to " start-dir)))))))
-
-
-(define (spublish:shell-mkdir targ-path)
- (if (file-exists? targ-path)
- (begin
- (print "Info: Target Directory " targ-path " already exist!!"))
- (let* ((th1 (make-thread
- (lambda ()
- (create-directory targ-path #t)
- (print " ... dir " targ-path " created"))
- "mkdir thread"))
- (th2 (make-thread
- (lambda ()
- (let loop ()
- (thread-sleep! 15)
- (display ".")
- (flush-output)
- (loop)))
- "action is happening thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- (cons #t "Successfully saved data"))))
-
-
-(define (spublish:shell-rm targ-path iport)
- (if (not (file-exists? targ-path))
- (begin
- (sauth:print-error (conc "target path " targ-path " does not exist!!")))
- (begin
- (print "Are you sure you want to delete " targ-path "?[y/n]")
- (let* ((inl (read-line iport)))
- (if (equal? inl "y")
- (let* ((th1 (make-thread
- (lambda ()
- (if (symbolic-link? targ-path)
- (delete-file targ-path )
- (if (directory? targ-path)
- (delete-directory targ-path #t)
- (delete-file targ-path )))
- (print " ... path " targ-path " deleted"))
- "rm thread"))
- (th2 (make-thread
- (lambda ()
- (let loop ()
- (thread-sleep! 15)
- (display ".")
- (flush-output)
- (loop)))
- "action is happening thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- (cons #t "Successfully saved data")))))))
-
-(define (spublish:shell-ln src-path target-path sub-path)
- (if (not (file-exists? sub-path))
- (sauth:print-error (conc "Path " sub-path " does not exist!! cannot proceed with link creation!!"))
- (begin
- (if (not (file-exists? src-path))
- (sauth:print-error (conc "Path " src-path " does not exist!! cannot proceed with link creation!!"))
- (begin
- (if (file-exists? target-path)
- (sauth:print-error (conc "Path " target-path "already exist!! cannot proceed with link creation!!"))
- (begin
- (create-symbolic-link src-path target-path )
- (print " ... link " target-path " created"))))))))
-
-(define (spublish:shell-help)
-(conc "Usage: [action [params ...]]
-
- ls [target path] : list contents of target area.
- cd : To change the current directory within the sretrive shell.
- pwd : Prints the full pathname of the current directory within the sretrive shell.
- mkdir : creates directory. Note it does not create's a path recursive manner.
- rm : removes files and emoty directories
- cp : copy a file/dir to target path. if src is a dir it automatically makes a recursive copy.
- ln TARGET LINK_NAME : creates a symlink
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)
-)
-
-(define (toplevel-command . args) #f)
-
-(define (spublish:shell area)
- ; (print area)
- (use readline)
-
- (let* ((path '())
- (prompt "spublish> ")
- (args (argv))
- (usr (current-user-name) )
- (top-areas (spublish:get-accessable-projects area))
- (close-port #f)
- (area-obj (get-obj-by-code area))
- (user-obj (get-user usr))
- (base-path (if (null? area-obj)
- ""
- (caddr (cdr area-obj))))
- (iport (make-readline-port prompt)))
- ;(print base-path)
- (if (null? area-obj)
- (begin
- (print "Area " area " does not exist")
- (exit 1)))
- ; (print "here")
- (let loop ((inl (read-line iport)))
- (if (not (or (or (eof-object? inl)
- (equal? inl "exit")) (port-closed? iport)))
- (let* ((parts (string-split inl))
- (cmd (if (null? parts) #f (car parts))))
- (if (and (not cmd) (not (port-closed? iport)))
- (loop (read-line))
- (case (string->symbol cmd)
- ((cd)
- (if (> (length parts) 1) ;; have a parameter
- (begin
- (let*((arg (cadr parts))
- (resolved-path (sauth-common:resolve-path arg path top-areas))
- (target-path (sauth-common:get-target-path path arg top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (or (equal? resolved-path #f) (not (file-exists? target-path)))
- (print "Invalid argument " arg ".. ")
- (begin
- (set! path resolved-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd"))))
- )))))
- (set! path '())))
- ((pwd)
- (if (null? path)
- (print "/")
- (print "/" (string-join path "/"))))
- ((ls)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (sauth-common:shell-ls-cmd path "" top-areas base-path '())
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) )
- ((< plen 2)
- (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '())
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))
- (else
- (if (equal? (car thepath) "|")
- (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
- (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))
- ((mkdir)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (print "mkdir takes one argument"))
- ((< plen 2)
- (let*((mk-path (cadr parts))
- (resolved-path (sauth-common:resolve-path mk-path path top-areas))
- (target-path (sauth-common:get-target-path path mk-path top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " mk-path ".. ")
- (begin
- (print "here")
- (spublish:shell-mkdir target-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir")))))))
- )))))
- ((rm)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (print "rm takes one argument"))
- ((< plen 2)
- (let*((rm-path (cadr parts))
- (resolved-path (sauth-common:resolve-path rm-path path top-areas))
- (target-path (sauth-common:get-target-path path rm-path top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " rm-path ".. ")
- (begin
- (spublish:shell-rm target-path iport)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))
- )))))
-
- ((cp publish)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((or (null? thepath) (< plen 2))
- (print "cp takes two argument"))
- ((< plen 3)
- (let*((src-path (car thepath))
- (dest-path (cadr thepath))
- (resolved-path (sauth-common:resolve-path dest-path path top-areas))
- (target-path (sauth-common:get-target-path path dest-path top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " dest-path ".. ")
- (begin
- (spublish:shell-cp src-path target-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp")))))))
- )))))
- ((ln)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((or (null? thepath) (< plen 2))
- (print "ln takes two argument"))
- ((< plen 3)
- (let*((src-path (car thepath))
- (dest-path (cadr thepath))
- (resolved-path (sauth-common:resolve-path dest-path path top-areas))
- (target-path (sauth-common:get-target-path path dest-path top-areas base-path))
- (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/")))))
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " dest-path ".. ")
- (begin
- (spublish:shell-ln src-path target-path sub-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln")))))))
- )))))
- ((exit)
- (print "got exit"))
- ((help)
- (print (spublish:shell-help)))
- (else
- (print "Got command: " inl))))
- (loop (read-line iport)))))))
-
-
-;;======================================================================
-;; MAIN
-;;======================================================================
-
-;(define (spublish:load-config exe-dir exe-name)
-; (let* ((fname (conc exe-dir "/." exe-name ".config")))
- ;; (ini:property-separator-patt " * *")
- ;; (ini:property-separator #\space)
-; (if (file-exists? fname)
-; ;; (ini:read-ini fname)
-; (read-config fname #f #t)
-; (make-hash-table))))
-
-(define (spublish:process-action action . args)
- ;(print args)
- (let* ((usr (current-user-name))
- (user-obj (get-user usr))
- (area (car args))
- (area-obj (get-obj-by-code area))
- (top-areas (spublish:get-accessable-projects area))
- (base-path (if (null? area-obj)
- ""
- (caddr (cdr area-obj))))
- (remargs (cdr args)))
- (if (null? area-obj)
- (begin
- (print "Area " area " does not exist")
- (exit 1)))
- (case (string->symbol action)
- ((cp publish)
- (if (< (length remargs) 2)
- (begin
- (print "ERROR: Missing arguments; spublish " )
- (exit 1)))
- (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
- (src-path-in (car filter-args))
- (dest-path (cadr filter-args))
- (src-path (with-input-from-pipe
- (conc "readlink -f " src-path-in)
- (lambda ()
- (read-line))))
- (msg (or (args:get-arg "-m") ""))
- (resolved-path (sauth-common:resolve-path (conc area "/" dest-path) `() top-areas))
- (target-path (sauth-common:get-target-path `() (conc area "/" dest-path) top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " dest-path ".. ")
- (begin
- (spublish:shell-cp src-path target-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp")))))))))
- ((mkdir)
- (if (< (length remargs) 1)
- (begin
- (print "ERROR: Missing arguments; ")
- (exit 1)))
- (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
- (mk-path (car filter-args))
- (msg (or (args:get-arg "-m") ""))
- (resolved-path (sauth-common:resolve-path mk-path (list area) top-areas))
- (target-path (sauth-common:get-target-path (list area) mk-path top-areas base-path)))
- (print "attempting to create directory " mk-path )
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " mk-path ".. ")
- (begin
- (spublish:shell-mkdir target-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir")))))))))
- ((ln)
- (if (< (length remargs) 2)
- (begin
- (print "ERROR: Missing arguments; " )
- (exit 1)))
- (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
- (src-path (car filter-args))
- (dest-path (cadr filter-args))
- (resolved-path (sauth-common:resolve-path dest-path (list area) top-areas))
- (target-path (sauth-common:get-target-path (list area) dest-path top-areas base-path))
- (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/")))))
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " dest-path ".. ")
- (begin
- (spublish:shell-ln src-path target-path sub-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" ln " src-path " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln")))))))))
- ((rm)
- (if (< (length remargs) 1)
- (begin
- (print "ERROR: Missing arguments; ")
- (exit 1)))
- (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
- (rm-path (car filter-args))
- (resolved-path (sauth-common:resolve-path rm-path (list area) top-areas))
- (prompt ">")
- (iport (make-readline-port prompt))
- (target-path (sauth-common:get-target-path (list area) rm-path top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (equal? resolved-path #f)
- (print "Invalid argument " rm-path ".. ")
- (begin
- (spublish:shell-rm target-path iport)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))))
- ((shell)
- (if (< (length args) 1)
- (begin
- (print "ERROR: Missing arguments area!!" )
- (exit 1))
- (spublish:shell area)))
- (else (print "Unrecognised command " action)))))
-
-;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
-;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
-;; (if (file-exists? debugcontrolf)
-;; (load debugcontrolf)))
-
-(define (main)
- (let* ((args (argv))
- (prog (car args))
- (rema (cdr args))
- (exe-name (pathname-file (car (argv)))))
- (cond
- ;; one-word commands
- ((eq? (length rema) 1)
- (case (string->symbol (car rema))
- ((help -h -help --h --help)
- (print spublish:help))
- (else
- (print "ERROR: Unrecognised command. Try \"spublish help\""))))
- ;; multi-word commands
- ((null? rema)(print spublish:help))
- ((>= (length rema) 2)
- (apply spublish:process-action (car rema)(cdr rema)))
- (else (print "ERROR: Unrecognised command2. Try \"spublish help\"")))))
-
-(main)
DELETED sretrieve.scm
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ /dev/null
@@ -1,1112 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-;;
-
-(use defstruct)
-(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 margs))
-
-(include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
-;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
-(include "sauth-paths.scm")
-(include "sauth-common.scm")
-
-(define (toplevel-command . args) #f)
-(use readline)
-
-
-
-
-;;
-;; GLOBALS
-;;
-(define *verbosity* 1)
-(define *logging* #f)
-(define *exe-name* (pathname-file (car (argv))))
-(define *sretrieve:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]
-
- ls : list contents of target area
- get : retrieve path to the data within
- -m \"message\" : why retrieved?
- shell : start a shell-like interface
-
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-;; replace (strftime('%s','now')), with datetime('now'))
-;(define (sretrieve:initialize-db db)
-; (for-each
-; (lambda (qry)
-; (exec (sql db qry)))
-; (list
-; "CREATE TABLE IF NOT EXISTS actions
-; (id INTEGER PRIMARY KEY,
-; action TEXT NOT NULL,
-; retriever TEXT NOT NULL,
-; datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
-; srcpath TEXT NOT NULL,
-; comment TEXT DEFAULT '' NOT NULL,
-; state TEXT DEFAULT 'new');"
-; "CREATE TABLE IF NOT EXISTS bundles
-; (id INTEGER PRIMARY KEY,
-; bundle TEXT NOT NULL,
-; release TEXT NOT NULL,
-; status TEXT NOT NULL,
-; event_date TEXT NOT NULL);"
-; )))
-;
-;(define (sretrieve:register-action db action submitter source-path comment)
-; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment)
-; (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment)
-; VALUES(?,?,?,?)")
-; action
-; submitter
-; source-path
-; (or comment "")))
-
-;; (call-with-database
-;; (lambda (db)
-;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
-;; ...))
-
-;; Create the sqlite db
-;(define (sretrieve:db-do configdat proc)
-; (let ((path (configf:lookup configdat "database" "location")))
-; (if (not path)
-; (begin
-; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
-; (exit 1)))
-; (if (and path
-; (directory? path)
-; (file-read-access? path))
-; (let* ((dbpath (conc path "/" *exe-name* ".db"))
-; (writeable (file-write-access? dbpath))
-; (dbexists (file-exists? dbpath)))
-; (handle-exceptions
-; exn
-; (begin
-; (debug:print 2 "ERROR: problem accessing db " dbpath
-; ((condition-property-accessor 'exn 'message) exn))
-; (exit 1))
-; ;;(debug:print 0 "calling proc " proc "db path " dbpath )
-; (call-with-database
-; dbpath
-; (lambda (db)
-; ;;(debug:print 0 "calling proc " proc " on db " db)
-; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-; (if (not dbexists)(sretrieve:initialize-db db))
-; (proc db)))))
-; (debug:print 0 "ERROR: invalid path for storing database: " path))))
-
-;; copy in directory to dest, validation is done BEFORE calling this
-;;
-;(define (sretrieve:get configdat retriever version comment)
-; (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
-; (datadir (conc base-dir "/" version)))
-; (if (or (not base-dir)
-; (not (file-exists? base-dir)))
-; (begin
-; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
-; (exit 1)))
-; (print datadir)
-; (if (not (file-exists? datadir))
-; (begin
-; (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
-; (exit 1)))
-;
-; (sretrieve:db-do
-; configdat
-; (lambda (db)
-; (sretrieve:register-action db "get" retriever datadir comment)))
-; (sretrieve:do-as-calling-user
-; (lambda ()
-; (if (directory? datadir)
-; (begin
-; (change-directory datadir)
-; (let ((files (filter (lambda (x)
-; (not (member x '("." ".."))))
-; (glob "*" ".*"))))
-; (print "files: " files)
-; (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read")))))
-; (begin
-; (let* ((parent-dir (pathname-directory datadir) )
-; (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
-; (change-directory parent-dir)
-; (process-execute "/bin/tar" (list "chfv" "-" filename))
-; )))
-;))))
-;
-;
-;;; copy in file to dest, validation is done BEFORE calling this
-;;;
-;(define (sretrieve:cp configdat retriever file comment)
-; (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
-; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
-; (datadir (conc base-dir "/" file))
-; (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
-; (if (or (not base-dir)
-; (not (file-exists? base-dir)))
-; (begin
-; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
-; (exit 1)))
-; (print datadir)
-; (if (not (file-exists? datadir))
-; (begin
-; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." )
-; (exit 1)))
-; (if (directory? datadir)
-; (begin
-; (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." )
-; (exit 1)))
-; (if(not (string-match (regexp allowed-sub-paths) file))
-; (begin
-; (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
-; (exit 1)))
-;
-; (sretrieve:db-do
-; configdat
-; (lambda (db)
-; (sretrieve:register-action db "cp" retriever datadir comment)))
-; (sretrieve:do-as-calling-user
-; ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " )
-; (change-directory (pathname-directory datadir))
-; ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) )
-; (process-execute "/bin/tar" (list "chfv" "-" filename)))
-; ))
-;
-;;; ls in file to dest, validation is done BEFORE calling this
-;;;
-;(define (sretrieve:ls configdat retriever file comment)
-; (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
-; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
-; (datadir (conc base-dir "/" file))
-; (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
-; (if (or (not base-dir)
-; (not (file-exists? base-dir)))
-; (begin
-; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
-; (exit 1)))
-; (print datadir)
-; (if (not (file-exists? datadir))
-; (begin
-; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." )
-; (exit 1)))
-; (if(not (string-match (regexp allowed-sub-paths) file))
-; (begin
-; (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
-; (exit 1)))
-;
-; (sretrieve:do-as-calling-user
-; (lambda ()
-; (process-execute "/bin/ls" (list "-ls" "-lrt" datadir ))
-; ))))
-
-
-
-(define (sretrieve:validate target-dir targ-mk)
- (let* ((normal-path (normalize-pathname targ-mk))
- (targ-path (conc target-dir "/" normal-path)))
- (if (string-contains normal-path "..")
- (begin
- (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir )
- (exit 1)))
-
- (if (not (string-contains targ-path target-dir))
- (begin
- (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
- (exit 1)))
- (debug:print 0 "Path " targ-mk " is valid.")
- ))
-
-
-;(define (sretrieve:backup-move path)
-; (let* ((trashdir (conc (pathname-directory path) "/.trash"))
-; (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
-; (create-directory trashdir #t)
-; (if (directory? path)
-; (system (conc "mv " path " " trashfile))
-; (file-move path trash-file))))
-;
-;
-;(define (sretrieve:lst->path pathlst)
-; (conc "/" (string-intersperse (map conc pathlst) "/")))
-;
-;(define (sretrieve:path->lst path)
-; (string-split path "/"))
-;
-;(define (sretrieve:pathdat-apply-heuristics configdat path)
-; (cond
-; ((file-exists? path) "found")
-; (else (conc path " not installed"))))
-
-;;======================================================================
-;; MISC
-;;======================================================================
-
-(define (sretrieve:do-as-calling-user proc)
- (let ((eid (current-effective-user-id))
- (cid (current-user-id)))
- (if (not (eq? eid cid)) ;; running suid
- (set! (current-effective-user-id) cid))
- ;; (debug:print 0 "running as " (current-effective-user-id))
- (proc)
- (if (not (eq? eid cid))
- (set! (current-effective-user-id) eid))))
-
-(define (sretrieve:find name paths)
- (if (null? paths)
- #f
- (let loop ((hed (car paths))
- (tal (cdr paths)))
- (if (file-exists? (conc hed "/" name))
- hed
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))
-
-(define (sretrieve:stderr-print . args)
- (with-output-to-port (current-error-port)
- (lambda ()
- (apply print args))))
-
-;;======================================================================
-;; SHELL
-;;======================================================================
-
-;; Create the sqlite db for shell
-;(define (sretrieve:shell-db-do path proc)
-; (if (not path)
-; (begin
-; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
-; (exit 1)))
-; (if (and path
-; (directory? path)
-; (file-read-access? path))
-; (let* ((dbpath (conc path "/" *exe-name* ".db"))
-; (writeable (file-write-access? dbpath))
-; (dbexists (file-exists? dbpath)))
-; (handle-exceptions
-; exn
-; (begin
-; (debug:print 2 "ERROR: problem accessing db " dbpath
-; ((condition-property-accessor 'exn 'message) exn))
-; (exit 1))
-; ;;(debug:print 0 "calling proc " proc "db path " dbpath )
-; (call-with-database
-; dbpath
-; (lambda (db)
-; ;;(debug:print 0 "calling proc " proc " on db " db)
-; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-; (if (not dbexists)(sretrieve:initialize-db db))
-; (proc db)))))
-; (debug:print 0 "ERROR: invalid path for storing database: " path)))
-
-
-
-;; function to find sheets to which use has access
-(define (sretrieve:has-permission area)
- (let ((username (current-user-name)))
- (cond
- ((is-admin username)
- #t)
- ((is-user "retrieve" username area)
- #t)
- ((is-user "publish" username area)
- #t)
- ((is-user "writer-admin" username area)
- #t)
- ((is-user "read-admin" username area)
- #t)
- ((is-user "area-admin" username area)
- #t)
- (else
- #f))))
-
-
-(define (sretrieve:get-accessable-projects area)
- (let* ((projects `()))
-
- (if (sretrieve:has-permission area)
- (set! projects (cons area projects))
- (begin
- (sauth:print-error (conc "User cannot access area " area "!!"))
- (exit 1)))
- ; (print projects)
- projects))
-
-(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
- (if (and (null? base-path-list) (equal? ext-path "") )
- (print (string-intersperse top-areas " "))
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
- ;(print resolved-path)
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- (print (string-intersperse top-areas " "))
- (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path)))
- ;(print "Resolved path: " target-path)
- (if (not (equal? target-path #f))
- (begin
- (if (symbolic-link? target-path)
- (set! target-path (conc target-path "/")))
- (if (not (equal? target-path #f))
- (begin
- (cond
- ((null? tail-cmd-list)
- (run (pipe
- (ls "-lrt" ,target-path))))
- ((not (equal? (car tail-cmd-list) "|"))
- (print "ls cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
- (else
- (run (pipe
- (ls "-lrt" ,target-path)
- (begin (system (string-join (cdr tail-cmd-list))))))
- ))))))))))))
-
-(define (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
- (data "") )
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- (print "Path could not be resolved!!")
- (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (or (not (file-exists? target-path)) (directory? target-path))
- (print "Target path does not exist or is a directory!")
- (begin
- (cond
- ((null? tail-cmd-list)
- (run (pipe
- (cat ,target-path))))
- ((not (equal? (car tail-cmd-list) "|"))
- (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
- (else
- (run (pipe
- (cat ,target-path)
- (begin (system (string-join (cdr tail-cmd-list))))))))))
-)))
- (print "Path could not be resolved!!"))))
-
-(define (get-options cmd-list split-str)
- (if (null? cmd-list)
- (list '() '())
- (let loop ((hed (car cmd-list))
- (tal (cdr cmd-list))
- (res '()))
- (cond
- ((equal? hed split-str)
- (list res tal))
- ((null? tal)
- (list (cons hed res) tal))
- (else
- (loop (car tal)(cdr tal)(cons hed res)))))))
-
-
-(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
- (pattern (car tail-cmd-list))
- (pipe-cmd-list (get-options (cdr tail-cmd-list) "|"))
- (options (string-join (car pipe-cmd-list)))
- (pipe-cmd (cadr pipe-cmd-list))
- (redirect-split (string-split (string-join tail-cmd-list) ">")) )
- (if(and ( > (length redirect-split) 2 ))
- (print "sgrep cmd cannot accept > " (string-join redirect-split) " as an argument!!" )
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- (print "Path could not be resolved!!")
- (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))
- (restrictions (if (equal? target-path #f)
- ""
- (sretrieve:shell-lookup base-path)))
- (rest-str (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") ))))
- (if (not (file-exists? target-path))
- (print "Target path does not exist!")
- (begin
- (cond
- ((and (null? pipe-cmd) (string-null? options))
- (run (pipe
- (grep ,pattern ,target-path ))))
- ((and (null? pipe-cmd) (not (string-null? options)))
- (run (pipe
- (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))))))
- ((and (not (null? pipe-cmd)) (string-null? options))
- (run (pipe
- (grep ,exclude-dir ,pattern ,target-path)
- (begin (system (string-join pipe-cmd))))))
- (else
- (run (pipe
- ;(grep ,options ,exclude-dir ,pattern ,target-path)
- (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))
-
- (begin (system (string-join pipe-cmd)))))))
-))))
- (print "Path could not be resolved!!")))))
-
-
-(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path)
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )))
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- (print "Path could not be resolved!!")
- (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (or (not (file-exists? target-path)) (directory? target-path))
- (print "Target path does not exist or is a directory!")
- (begin
- ;(sretrieve:shell-db-do
- ; db-location
- ; (lambda (db)
- ; (sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less " target-path))))
-
- (setenv "LESSSECURE" "1")
- (run (pipe
- (less ,target-path))))))))
- (print "Path could not be resolved!!"))))
-
-
-
-(define (sretrieve:shell-lookup base-path)
- (let* ((usr (current-user-name))
- (value (get-restrictions base-path usr)))
- value))
-
-
-(define (sretrieve:load-shell-config fname)
- (if (file-exists? fname)
- (read-config fname #f #f)
- ))
-
-
-(define (is_directory target-path)
- (let* ((retval #f))
- (sretrieve:do-as-calling-user
- (lambda ()
- ;(print (current-effective-user-id) )
- (if (directory? target-path)
- (set! retval #t))))
- ;(print (current-effective-user-id))
- retval))
-
-(define (make-exclude-pattern restriction-list )
- (if (null? restriction-list)
- ""
- (let loop ((hed (car restriction-list))
- (tal (cdr restriction-list))
- (ret-str ""))
- (cond
- ((null? tal)
- (conc ret-str ".+" hed ".*"))
- (else
- (loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|")))))) )
-
-(define (sretrieve:get-shell-cmd target-path base-path restrictions iport)
- (if (not (file-exists? target-path))
- (sauth:print-error "Target path does not exist!")
- (begin
- (if (not (equal? target-path #f))
- (begin
- (if (is_directory target-path)
- (begin
- (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe"))
- (parent-dir target-path)
- (last-dir-name (if (pathname-extension target-path)
- (conc(pathname-file target-path) "." (pathname-extension target-path))
- (pathname-file target-path)))
- (curr-dir (current-directory))
- (start-dir (conc (current-directory) "/" last-dir-name))
- (execlude (make-exclude-pattern (string-split restrictions ","))))
- ; (print tmpfile)
- (if (file-exists? start-dir)
- (begin
- (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]")
- (let* ((inl (read-line iport)))
- (if (equal? inl "y")
- (begin
- (change-directory parent-dir)
- (create-fifo tmpfile)
- (process-fork
- (lambda()
- (sleep 1)
- (with-output-to-file tmpfile
- (lambda ()
- (sretrieve:make_file parent-dir execlude parent-dir)))))
-
- (run (pipe
- (tar "chfv" "-" "-T" ,tmpfile )
- (begin (system (conc "cd " start-dir ";tar xUf - " )))))
- (change-directory curr-dir)
- (system (conc "rm " tmpfile)) )
- (begin
- (print "Nothing has been retrieved!! ")))))
- (begin
- (sretrieve:do-as-calling-user
- (lambda ()
- (create-directory start-dir #t)))
- (change-directory parent-dir)
- ; (print execlude)
- (create-fifo tmpfile)
- (process-fork
- (lambda()
- (sleep 1)
- (with-output-to-file tmpfile
- (lambda ()
- (sretrieve:make_file parent-dir execlude parent-dir)))))
-
- (run (pipe
- (tar "chfv" "-" "-T" ,tmpfile)
- (begin (system (conc "cd " start-dir ";tar xUf - " )))))
- (change-directory curr-dir)
- (system (conc "rm " tmpfile))))))
- (begin
- (let*((parent-dir (pathname-directory target-path))
- (start-dir (current-directory))
- (filename (if (pathname-extension target-path)
- (conc(pathname-file target-path) "." (pathname-extension target-path))
- (pathname-file target-path)))
- (work-dir-file (conc (current-directory) "/" filename)))
- (if (file-exists? work-dir-file)
- (begin
- (print filename " already exist in your work dir. Do you want to over write it? [y|n]")
- (let* ((inl (read-line iport)))
- (if (equal? inl "y")
- (begin
- (change-directory parent-dir)
- (run (pipe
- (tar "chfv" "-" ,filename)
- (begin (system (conc "cd " start-dir ";tar xUf - " )))))
- (change-directory start-dir))
- (begin
- (print "Nothing has been retrieved!! ")))))
- (begin
- (change-directory parent-dir)
- (run (pipe
- (tar "chfv" "-" ,filename)
- (begin (system (conc "cd " start-dir ";tar xUf -")))))
- (change-directory start-dir)))))))))))
-
-(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)
- (handle-exceptions
- exn
- (begin
- (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: "
- ((condition-property-accessor 'exn 'message) exn)))
- (exit 1))
-
- (if (not (file-exists? target-path))
- (sauth:print-error "Error:Target path does not exist!")
- (begin
- (if (not (equal? target-path #f))
- (begin
- (if (is_directory target-path)
- (begin
- (let* ((parent-dir target-path)
- (last-dir-name (if (pathname-extension target-path)
- (conc(pathname-file target-path) "." (pathname-extension target-path))
- (pathname-file target-path)))
- (curr-dir (current-directory))
- (start-dir (conc (current-directory) "/" last-dir-name))
- (execlude (make-exclude-pattern (string-split restrictions ",")))
- (tmpfile (conc "/tmp/my-pipe-" (current-process-id))))
- (if (file-exists? start-dir)
- (begin
- (sauth:print-error (conclast-dir-name " already exist in your work dir."))
- (sauth:print-error "Nothing has been retrieved!! "))
- (begin
- ; (sretrieve:do-as-calling-user
- ; (lambda ()
- ; (print tmpfile)
- ;(if (not (file-exists? (conc "/tmp/" (current-user-name))))
- ; (create-directory (conc "/tmp/" (current-user-name)) #t))
- (change-directory parent-dir)
- (create-fifo tmpfile)
- (process-fork
- (lambda()
- (sleep 1)
- (with-output-to-file tmpfile
- (lambda ()
- (sretrieve:make_file parent-dir execlude parent-dir)))))
-
- (process-execute "/bin/tar" (append (list "chfv" "-" "-T" tmpfile) (list "--ignore-failed-read")))
- ;(run (pipe
- ;(tar "chfv" "-" "." )
- ;(begin (system (conc "cd " start-dir ";tar xUf - " execlude )))))
- (system (conc "rm " tmpfile))
- (change-directory curr-dir)))))
- (begin
- (let*((parent-dir (pathname-directory target-path))
- (start-dir (current-directory))
- (filename (if (pathname-extension target-path)
- (conc(pathname-file target-path) "." (pathname-extension target-path))
- (pathname-file target-path)))
- (work-dir-file (conc (current-directory) "/" filename)))
- (if (file-exists? work-dir-file)
- (begin
- (print filename " already exist in your work dir.")
- (print "Nothing has been retrieved!! "))
- (begin
- (change-directory parent-dir)
- (process-execute "/bin/tar" (append (append (list "chfv" "-") (list filename)) (list "--ignore-failed-read")))
- ;(run (pipe
- ; (tar "chfv" "-" ,filename)
- ; (begin (system (conc "cd " start-dir ";tar xUf -")))))
- (change-directory start-dir))))))))))))
-
-(define (sretrieve:make_file path exclude base_path)
- (find-files
- path
- action: (lambda (p res)
- (cond
- ((symbolic-link? p)
- (if (directory?(read-symbolic-link p))
- (sretrieve:make_file p exclude base_path)
- (print (string-substitute (conc base_path "/") "" p "-"))))
- ((directory? p)
- ;;do nothing for dirs)
- )
- (else
-
- (if (not (string-match (regexp exclude) p ))
- (print (string-substitute (conc base_path "/") "" p "-"))))))
- dotfiles: #t))
-
-(define (sretrieve:shell-help)
-(conc "Usage: " *exe-name* " [action [params ...]]
-
- ls [target path] : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls | grep txt
- cd : To change the current directory within the sretrive shell.
- pwd : Prints the full pathname of the current directory within the sretrive shell.
- get : download directory/files into the directory where sretrieve shell cmd was invoked
- less : Read input file to allows backward movement in the file as well as forward movement
- cat : show the contents of a file. The output of the cmd can be piped into other system cmd.
-
- sgrep [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd.
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)
-)
-;(define (toplevel-command . args) #f)
-(define (sretrieve:shell area)
- ; (print area)
- (use readline)
- (let* ((path '())
- (prompt "sretrieve> ")
- (args (argv))
- (usr (current-user-name) )
- (top-areas (sretrieve:get-accessable-projects area))
- (close-port #f)
- (area-obj (get-obj-by-code area))
- (user-obj (get-user usr))
- (base-path (if (null? area-obj)
- ""
- (caddr (cdr area-obj))))
- (iport (make-readline-port prompt)))
- (if (null? area-obj)
- (begin
- (print "Area " area " does not exist")
- (exit 1)))
- (let loop ((inl (read-line iport)))
- ;(print 1)
- (if (not (or (or (eof-object? inl)
- (equal? inl "exit")) (port-closed? iport)))
- (let* ((parts (string-split inl))
- (cmd (if (null? parts) #f (car parts))))
- ; (print "2")
- (if (and (not cmd) (not (port-closed? iport)))
- (loop (read-line))
- (case (string->symbol cmd)
- ((cd)
- (if (> (length parts) 1) ;; have a parameter
- (begin
- (let*((arg (cadr parts))
- (resolved-path (sauth-common:resolve-path arg path top-areas))
- (target-path (sauth-common:get-target-path path arg top-areas base-path)))
- (if (not (equal? target-path #f))
- (if (or (equal? resolved-path #f) (not (file-exists? target-path)))
- (print "Invalid argument " arg ".. ")
- (begin
- (set! path resolved-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd"))))
- )))))
- (set! path '())))
- ((pwd)
- (if (null? path)
- (print "/")
- (print "/" (string-join path "/"))))
- ((ls)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (sauth-common:shell-ls-cmd path "" top-areas base-path '())
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) )
- ((< plen 2)
-
- (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '())
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))
- (else
- (if (equal? (car thepath) "|")
- (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
- (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))
- ((cat)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (print "Error: Missing argument to cat"))
- ((< plen 2)
- (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path '())
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat")))))
-
- (else
- (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path (cdr thepath))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat"))))
-))))
- ((sgrep)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (print "Error: Missing arguments to grep!! Useage: grep [options] "))
- ((< plen 2)
- (print "Error: Missing arguments to grep!! Useage: grep [options] "))
- (else
- (sretrieve:shell-grep-cmd path (car thepath) top-areas base-path (cdr thepath))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "grep"))))))))
-
- ((less)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (print "Error: Missing argument to less"))
- ((< plen 2)
- (sretrieve:shell-less-cmd path (car thepath) top-areas base-path)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "less")))))
- (else
- (print "less cmd takes only one () argument!!")))))
- ((get)
- (let* ((thepath (if (> (length parts) 1) ;; have a parameter
- (cdr parts)
- `()))
- (plen (length thepath)))
- (cond
- ((null? thepath)
- (print "Error: Missing argument to get"))
- ((< plen 2)
- (let* ((target-path (sauth-common:get-target-path path (car thepath) top-areas base-path))
- (restrictions (if (equal? target-path #f)
- ""
- (sretrieve:shell-lookup base-path))))
- (if (not (equal? target-path #f))
- (begin
- (sretrieve:get-shell-cmd target-path base-path restrictions iport)
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "get"))))))))
- (else
- (print "Error: get cmd takes only one argument ")))))
- ((exit)
- (print "got exit"))
- ((help)
- (print (sretrieve:shell-help)))
- (else
- (print "Got command: " inl))))
- (loop (read-line iport)))))))
-;;))
-
-
-;;======================================================================
-;; MAIN
-;;======================================================================
-;;(define *default-log-port* (current-error-port))
-
-;(define (sretrieve:load-config exe-dir exe-name)
-; (let* ((fname (conc exe-dir "/." exe-name ".config")))
-; ;; (ini:property-separator-patt " * *")
-; ;; (ini:property-separator #\space)
-; (if (file-exists? fname)
-; ;; (ini:read-ini fname)
-; (read-config fname #f #f)
-; (make-hash-table))))
-
-;; package-type is "megatest", "builds", "kits" etc.
-;;
-
-;(define (sretrieve:load-packages configdat exe-dir package-type)
-; (push-directory exe-dir)
-; (let* ((packages-metadir (configf:lookup configdat "settings" "packages-metadir"))
-; (conversion-script (configf:lookup configdat "settings" "conversion-script"))
-; (upstream-file (configf:lookup configdat "settings" "upstream-file"))
-; (package-config (conc packages-metadir "/" package-type ".config")))
-; (if (file-exists? upstream-file)
-; (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
-; (> (file-modification-time upstream-file)(file-modification-time package-config)))
-; (handle-exceptions
-; exn
-; (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
-; (let ((pid (process-run conversion-script (list upstream-file package-config))))
-; (process-wait pid)))
-; (debug:print 0 "Skipping update of " package-config " from " upstream-file))
-; (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found"))
-; (let ((res (if (file-exists? package-config)
-; (begin
-; (debug:print 0 "Reading package config " package-config)
-; (read-config package-config #f #t))
-; (make-hash-table))))
-; (pop-directory)
-; res)))
-
-(define (toplevel-command . args) #f)
-(define (sretrieve:process-action action . args)
- ; (print action)
- ; (use readline)
- (case (string->symbol action)
- ((get)
- (if (< (length args) 2)
- (begin
- (sauth:print-error "Missing arguments; " )
- (exit 1)))
- (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0))
- (iport (make-readline-port ">"))
- (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))))
- (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:get-shell-cmd-line target-path base-path restrictions iport))))))
- ((cp)
- (if (< (length args) 2)
- (begin
- (sauth:print-error "Missing arguments; " )
- (exit 1)))
- (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0))
- (iport (make-readline-port ">"))
- (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))))
- ; (print args)
- (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))))
- ;(print target-path)
- (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: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; ")
- (exit 1)))
- ((equal? (length args) 1)
- (let* ((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)))))
- (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)
- (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0))
- (usr (current-user-name))
- (user-obj (get-user usr))
- (area (car args)))
- (let* ((area-obj (get-obj-by-code area))
- (top-areas (sretrieve:get-accessable-projects area))
- (base-path (if (null? area-obj)
- ""
- (caddr (cdr area-obj))))
-
- (sub-path (if (null? remargs)
- area
- (conc area "/" (car remargs)))))
- ;(print "sub path " sub-path)
- (if (null? area-obj)
- (begin
- (print "Area " area " does not exist")
- (exit 1)))
- (sauth-common:shell-ls-cmd `() sub-path top-areas base-path '())
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))))
-
- ((shell)
- (if (< (length args) 1)
- (begin
- (print "ERROR: Missing arguments !!" )
- (exit 1))
- (sretrieve:shell (car args))))
- (else (print 0 "Unrecognised command " action))))
-
-(define (main)
- (let* ((args (argv))
- (prog (car args))
- (rema (cdr args))
- (exe-name (pathname-file (car (argv))))
- ;(exe-dir (or (pathname-directory prog)
- ; (sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":"))))
- ;(configdat (sretrieve:load-config exe-dir exe-name))
-)
- ;; preserve the exe data in the config file
- ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name)
- ; (list "exe-dir" exe-dir)))
- (cond
- ;; one-word commands
- ((eq? (length rema) 1)
- (case (string->symbol (car rema))
- ((help -h -help --h --help)
- (print sretrieve:help))
- (else
- (print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
- ;; multi-word commands
- ((null? rema)(print sretrieve:help))
- ((>= (length rema) 2)
-
- (apply sretrieve:process-action (car rema) (cdr rema)))
- (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))
-
-(main)
-
-
-