Index: sauth-common.scm ================================================================== --- sauth-common.scm +++ sauth-common.scm @@ -184,15 +184,45 @@ (set! obj data-row)))) obj)) (define (get-obj-by-code code ) (let* ((obj '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'"))))) + (set! obj data-row) + ))) + (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)) + ;; function to validate the users input for target path and resolve the path ;; TODO: Check for restriction in subpath @@ -224,18 +254,21 @@ (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) "/"))))) - ; (print restricted-areas) - (if (and (not (equal? restricted-areas "" )) + + + (if (and (not (equal? restricted-areas "" )) (string-match (regexp restrictions) target-path)) - (begin - (print "Access denied to " (string-join resolved-path "/")) - ;(exit 1) - #f) - target-path))) + (begin + (sauth:print-error "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 " ")) @@ -255,10 +288,12 @@ ((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)))))) - ) -))) -)))))) + (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))))) Index: sauthorize.scm ================================================================== --- sauthorize.scm +++ sauthorize.scm @@ -40,12 +40,12 @@ 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 - sauth open --retrieve|--publish : update the binaries with the lates changes + --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. @@ -86,10 +86,11 @@ "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, @@ -209,14 +210,14 @@ (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) +(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 code))) + (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 @@ -244,12 +245,12 @@ (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) values ('" code "', '" path "', '" exe-name "') ")) - (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') ")))))))) + (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 @@ -273,11 +274,11 @@ #f) (else (loop (car tal)(cdr tal)))))) ;create executables with appropriate suids -(define (sauthorize:open user path group code access-type) +(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 @@ -295,11 +296,11 @@ (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) + (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 )))) @@ -452,13 +453,15 @@ (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))) + (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 @@ -471,10 +474,11 @@ (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)))))) @@ -482,15 +486,17 @@ ((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") '() args:arg-hash 0)) + (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") "")) + (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 "") @@ -501,12 +507,12 @@ (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))) - - (sauthorize:open username path group area access-type))) + ; (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))) Index: spublish.scm ================================================================== --- spublish.scm +++ spublish.scm @@ -8,43 +8,20 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use defstruct) (use scsh-process) - (use refdb) - - -;; (use ssax) -;; (use sxml-serializer) -;; (use sxml-modifications) -;; (use regex) -;; (use srfi-69) -;; (use regex-case) -;; (use posix) -;; (use json) -;; (use csv) (use srfi-18) (use srfi-19) - (use format) - -;; (require-library ini-file) -;; (import (prefix ini-file ini:)) - (use sql-de-lite srfi-1 posix regex regex-case srfi-69) -;; (import (prefix sqlite3 sqlite3:)) -;; + (declare (uses configf)) ;; (declare (uses tree)) (declare (uses margs)) -;; (declare (uses dcommon)) -;; (declare (uses launch)) -;; (declare (uses gutils)) -;; (declare (uses db)) -;; (declare (uses synchash)) -;; (declare (uses server)) + (declare (uses megatest-version)) ;; (declare (uses tbd)) (include "megatest-fossil-hash.scm") ;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. @@ -84,237 +61,237 @@ ;;====================================================================== (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)) +;(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.") - )) +;(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"))) +;(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"))) +;(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: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) @@ -336,43 +313,41 @@ ;;====================================================================== ;; 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))))))) +;(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 `())) - ; (print "in spublish:get-accessable-projects") - ;(print (spublish:has-permission area)) - (if (spublish:has-permission area) + (if (spublish:has-permission area) (set! projects (cons area projects)) (begin (print "User cannot access area " area "!!") (exit 1))) - ; (print "exiting spublish:get-accessable-projects") projects)) ;; function to find sheets to which use has access (define (spublish:has-permission area) ;(print "in spublish:has-permission") @@ -388,12 +363,11 @@ ((equal? (is-user "area-admin" username area) #t) (set! ret-val #t)) (else (set! ret-val #f))) - ; (print ret-val) - ret-val)) + ret-val)) (define (is_directory target-path) (let* ((retval #f)) (sauthorize:do-as-calling-user (lambda () @@ -401,11 +375,13 @@ (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)) (print "ERROR: target Directory " target-path " does not exist!!")) ((not (file-exists? src-path)) @@ -413,11 +389,10 @@ (else (if (is_directory src-path) (begin (let* ((parent-dir src-path) (start-dir target-path)) - ;(print "parent-dir " parent-dir " start-dir " start-dir) (run (pipe (begin (system (conc "cd " parent-dir " ;tar chf - ." ))) (begin (change-directory start-dir) ;(print "123") (run-cmd "tar" (list "xf" "-"))))) @@ -467,11 +442,10 @@ (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 () - ;(print "hi") (if (directory? targ-path) (delete-directory targ-path #t) (delete-file targ-path )) (print " ... path " targ-path " deleted")) "rm thread")) @@ -606,10 +580,11 @@ (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"))))))) ))))) @@ -691,18 +666,18 @@ ;;====================================================================== ;; MAIN ;;====================================================================== -(define (spublish:load-config exe-dir exe-name) - (let* ((fname (conc exe-dir "/." exe-name ".config"))) +;(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)))) +; (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)) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -8,24 +8,15 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use defstruct) (use scsh-process) - (use srfi-18) (use srfi-19) -;;(use utils) -;;(use format) (use refdb) -;; (require-library ini-file) -;; (import (prefix ini-file ini:)) - (use sql-de-lite srfi-1 posix regex regex-case srfi-69) -;; (import (prefix sqlite3 sqlite3:)) -;; (declare (uses common)) - (declare (uses configf)) (declare (uses margs)) (declare (uses megatest-version)) @@ -65,176 +56,176 @@ ;;====================================================================== ;; 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 ""))) +;(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)))) +;(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: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)) @@ -250,29 +241,29 @@ (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")))) +;(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 ;;====================================================================== @@ -304,41 +295,37 @@ ;;====================================================================== ;; SHELL ;;====================================================================== - -(define *refdb* "/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/refdb") -(define *refdbloc* "/nfs/site/disks/ch_ciaf_disk023/fdk_gwa_disk003/pjhatwal/fossil/megatest1.60/megatest/datashare-testing/sretrieve_configs") - ;; 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))) +;(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) @@ -357,13 +344,10 @@ ((is-user "area-admin" username area) #t) (else #f)))) - - - (define (sretrieve:get-accessable-projects area) (let* ((projects `())) (if (sretrieve:has-permission area) @@ -382,10 +366,12 @@ (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 @@ -396,11 +382,11 @@ (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)) @@ -620,12 +606,19 @@ (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) - (if (not (file-exists? target-path)) - (print "Target path does not exist!") + (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)) + (print "Error:Target path does not exist!") (begin (if (not (equal? target-path #f)) (begin (if (is_directory target-path) (begin @@ -642,11 +635,13 @@ (print last-dir-name " already exist in your work dir.") (print "Nothing has been retrieved!! ")) (begin ; (sretrieve:do-as-calling-user ; (lambda () - ;(create-directory start-dir #t))) + + (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) @@ -675,11 +670,11 @@ (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))))))))))) + (change-directory start-dir)))))))))))) (define (sretrieve:make_file path exclude base_path) (find-files path action: (lambda (p res) @@ -871,48 +866,49 @@ ;;====================================================================== ;; 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)))) +;(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 configdat action . args) +;(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 @@ -935,13 +931,13 @@ (if (null? area-obj) (begin (print "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)))) + (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")))) @@ -1031,23 +1027,24 @@ (if (< (length args) 1) (begin (print "ERROR: Missing arguments !!" ) (exit 1)) (sretrieve:shell (car args)))) - (else (debug:print 0 "Unrecognised command " action)))) + (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))) + ;(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))) + ;(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) @@ -1055,12 +1052,13 @@ (else (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) ;; multi-word commands ((null? rema)(print sretrieve:help)) ((>= (length rema) 2) - (apply sretrieve:process-action configdat (car rema)(cdr rema))) + + (apply sretrieve:process-action (car rema) (cdr rema))) (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\""))))) (main)