Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ sauthorize.scm
@@ -37,19 +37,20 @@
(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.
- sauthorize list-area-user : list the users that can access the area.
- sauthorize open --group : Open up an area. User needs to be the owner of the area to open it.
+ 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
- sauthorize grant --area : Grant permission to read or write to a area that is alrady opend up.
+ sauth grant --area : Grant permission to read or write to a area that is alrady opend up.
--expiration yyyy/mm/dd --retrieve|--publish
[--restrict ]
- sauthorize read-shell : Open sretrieve shell for reading.
- sauthorize write-shell : Open spublish shell for writing.
+ 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)) ;; "
@@ -171,13 +172,15 @@
(lambda ()
(run-cmd "/bin/cp" (list spath dpath ))
(if (equal? access-type "publish")
(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))))
-))
+ (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
@@ -191,11 +194,12 @@
;check if a paths/codes are vaid and if area is alrady open
(define (open-area group path code access-type)
(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 code)))
+ ;(print path-obj)
(cond
((not (null? path-obj))
(if (equal? code (car path-obj))
(begin
(if (equal? exe-name (cadr path-obj))
@@ -218,13 +222,15 @@
((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) values ('" code "', '" path "', '" exe-name "') "))
(sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') "))))))))
(define (user-has-open-perm user path access)
(let* ((has-access #f)
(eid (current-user-id)))
@@ -250,23 +256,31 @@
(else
(loop (car tal)(cdr tal))))))
;create executables with appropriate suids
(define (sauthorize:open user path group code access-type)
- (let* ((req_grpid (caddr (group-information group)))
+ (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 (is-group-washed req_grpid current-grp-list)))
- (if (equal? valid-grp #f )
+ (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
+ (begin
+ ;(print "here")
(open-area group path code access-type)
(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 ))))
@@ -371,15 +385,51 @@
(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 reading!!")
+ (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)))
+ (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) ) (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)))
+ (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
@@ -404,10 +454,32 @@
(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)))
+ ((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 ')" ))))))
+
((register-log)
(if (< (length args) 4)
(print "Invalid arguments"))
;(print args)
(let* ((cmd-line (car args))
@@ -446,12 +518,12 @@
(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 "'")))))
- )
+ (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)
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -55,19 +55,18 @@
;;
;; 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
- log :
-
+(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.
@@ -418,11 +417,12 @@
;(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" "-")))))))
+ (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))
@@ -429,12 +429,12 @@
(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" "-")))
- ))))))))
+ (run-cmd "tar" (list "xf" "-")))))
+ (print "Copied data to " start-dir)))))))
(define (spublish:shell-mkdir targ-path)
(if (file-exists? targ-path)
(begin
@@ -692,145 +692,109 @@
;; (ini:read-ini fname)
(read-config fname #f #t)
(make-hash-table))))
(define (spublish:process-action action . args)
- (let* (
- ;; (target-dir (configf:lookup configdat "settings" "target-dir"))
- (user (current-user-name))
- ;;(allowed-users (string-split
- ;; (or (configf:lookup configdat "settings" "allowed-users")
- ;; "")))
-)
+ ;(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 args) 2)
+ (if (< (length remargs) 2)
(begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (print "ERROR: Missing arguments; spublish " )
(exit 1)))
- (let* ((remargs (args:get-args args '("-m") '() args:arg-hash 0))
- (dest-dir (cadr args))
- (src-path-in (car args))
+ (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") ""))
- (targ-file (pathname-strip-directory src-path)))
- (if (not (file-read-access? src-path))
- (begin
- (print "ERROR: source file not readable: " src-path)
- (exit 1)))
- (if (directory? src-path)
- (begin
- (print "ERROR: source file is a directory, this is not supported yet.")
- (exit 1)))
- (print "publishing " src-path-in " to " target-dir)
- (spublish:validate target-dir dest-dir)
- (spublish:cp configdat user src-path target-dir targ-file dest-dir msg)))
- ((tar)
- (if (< (length args) 1)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((dst-dir (car args))
- (msg (or (args:get-arg "-m") "")))
- (spublish:validate target-dir dst-dir)
- (spublish:tar configdat user target-dir dst-dir msg)))
-
- ((mkdir)
- (if (< (length args) 1)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((targ-mk (car args))
- (msg (or (args:get-arg "-m") "")))
- (print "attempting to create directory " targ-mk " in " target-dir)
- (spublish:validate target-dir targ-mk)
- (spublish:mkdir configdat user target-dir targ-mk msg)))
-
- ((ln)
- (if (< (length args) 2)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((targ-link (car args))
- (link-name (cadr args))
- (sub-path (string-reverse (string-join (cdr (string-split (string-reverse link-name) "/")) "/")))
- (msg (or (args:get-arg "-m") "")))
- (if (> (string-length(string-trim sub-path)) 0)
- (begin
- (print "attempting to create directory " sub-path " in " target-dir)
- (spublish:validate target-dir sub-path)
- (print (conc target-dir "/" sub-path ) )
- (print (directory-exists?(conc target-dir "/" sub-path )))
- (if (directory-exists?(conc target-dir "/" sub-path ))
- (print "Target Directory " (conc target-dir sub-path ) " exist!!")
- (spublish:mkdir configdat user target-dir sub-path msg))))
-
- (print "attempting to create link " link-name " in " target-dir)
- (spublish:ln configdat user target-dir targ-link link-name msg)))
-
+ (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 args) 1)
+ (if (< (length remargs) 1)
(begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (print "ERROR: Missing arguments; ")
(exit 1)))
- (let* ((targ-file (car args))
- (msg (or (args:get-arg "-m") "")))
- (print "attempting to remove " targ-file " from " target-dir)
- (spublish:validate target-dir targ-file)
-
- (spublish:rm configdat user target-dir targ-file msg)))
- ((publish)
- (if (< (length args) 3)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1))
- (let* ((srcpath (list-ref args 0))
- (areaname (list-ref args 1))
- (version (list-ref args 2))
- (remargs (args:get-args (drop args 2)
- '("-type" ;; link or copy (default is copy)
- "-m")
- '()
- args:arg-hash
- 0))
- (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
- (comment (or (args:get-arg "-m") ""))
- (submitter (current-user-name))
- (quality (args:get-arg "-quality"))
- (publish-res (spublish:publish configdat publish-type areaname version comment srcpath submitter quality)))
- (if (not (car publish-res))
- (begin
- (print "ERROR: " (cdr publish-res))
- (exit 1))))))
- ((list-versions)
- (let ((area-name (car args)) ;; version patt full print
- (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
- (db (spublish:open-db configdat))
- (versions (spublish:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
- ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
- (map (lambda (x)
- (if (args:get-arg "-full")
- (format #t
- "~10a~10a~4a~27a~30a\n"
- (vector-ref x 0)
- (vector-ref x 1)
- (vector-ref x 2)
- (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
- (conc "\"" (vector-ref x 4) "\""))
- (print (vector-ref x 0))))
- versions)))
- ((shell)
+ (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))
+ (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)
+ (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 (car args)))
- )
-
+ (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)
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -9,20 +9,10 @@
;; PURPOSE.
(use defstruct)
(use scsh-process)
-;; (use ssax)
-;; (use sxml-serializer)
-;; (use sxml-modifications)
-;; (use regex)
-;; (use srfi-69)
-;; (use regex-case)
-;; (use posix)
-;; (use json)
-;; (use csv)
-;; (use directory-utils)
(use srfi-18)
(use srfi-19)
;;(use utils)
;;(use format)
(use refdb)
@@ -33,25 +23,22 @@
;; (import (prefix sqlite3 sqlite3:))
;;
(declare (uses common))
(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.
(include "sauth-paths.scm")
(include "sauth-common.scm")
+
+(define (toplevel-command . args) #f)
+(use readline)
+
;;
;; GLOBALS
;;
(define *verbosity* 1)
@@ -59,16 +46,14 @@
(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 data for release
- -m \"message\" : why retrieved?
- cp : copy file to current directory
- log : get listing of recent downloads
- shell : start a shell-like interface
+ 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)) ;; "
@@ -117,11 +102,10 @@
;; (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)))
@@ -181,12 +165,11 @@
(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)
@@ -398,11 +381,13 @@
;(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)
+ ;(print "Resolved path: " target-path)
+ (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
@@ -545,53 +530,72 @@
(let loop ((hed (car restriction-list))
(tal (cdr restriction-list))
(ret-str ""))
(cond
((null? tal)
- (conc ret-str " --exclude='*" hed "*'"))
+ (conc ret-str ".+" hed ".*"))
(else
- (loop (car tal)(cdr tal)(conc ret-str " --exclude='*" hed "*'")))))) )
+ (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))
(print "Target path does not exist!")
(begin
(if (not (equal? target-path #f))
(begin
(if (is_directory target-path)
(begin
- (let* ((parent-dir target-path)
+ (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 execlude)
- (print (file-exists? start-dir))
- (if (file-exists? start-dir)
+ ; (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" "-" "." )
- (begin (system (conc "cd " start-dir ";tar xUf - " execlude )))))
- (change-directory curr-dir))
+ (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" "-" "." )
- (begin (system (conc "cd " start-dir ";tar xUf - " execlude )))))
- (change-directory curr-dir)))))
+ (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))
@@ -603,22 +607,96 @@
(let* ((inl (read-line iport)))
(if (equal? inl "y")
(begin
(change-directory parent-dir)
(run (pipe
- (tar "chfv" "-" "." )
- (begin (system (conc "cd " start-dir ";tar xUf - " execlude )))))
- (change-directory curr-dir))
+ (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))))))))
- (print (current-directory)))))
+ (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!")
+ (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/" (current-user-name) "/my-pipe-" (current-process-id))))
+ (if (file-exists? start-dir)
+ (begin
+ (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)))
+ (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 "-"))))))))
(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
@@ -632,11 +710,11 @@
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 (toplevel-command . args) #f)
(define (sretrieve:shell area)
; (print area)
(use readline)
(let* ((path '())
(prompt "sretrieve> ")
@@ -770,14 +848,16 @@
((< 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")))) ))
+ (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)
@@ -827,54 +907,134 @@
(read-config package-config #f #t))
(make-hash-table))))
(pop-directory)
res)))
+;(define (toplevel-command . args) #f)
(define (sretrieve:process-action configdat action . args)
+ ; (use readline)
(case (string->symbol action)
((get)
- (if (< (length args) 1)
- (begin
- (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
- (version (car args))
- (msg (or (args:get-arg "-m") ""))
- (package-type (or (args:get-arg "-package")
- default-area))
- (exe-dir (configf:lookup configdat "exe-info" "exe-dir")))
- (debug:print 0 "retrieving " version " of " package-type " as tar data on stdout")
- (sretrieve:get configdat user version msg)))
- ((cp)
- (if (< (length args) 1)
- (begin
- (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
- (file (car args))
- (msg (or (args:get-arg "-m") "")) )
-
- (debug:print 0 "copinging " file " to current directory " )
- (sretrieve:cp configdat user file msg)))
- ((ls)
- (if (< (length args) 1)
- (begin
- (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
- (dir (car args))
- (msg (or (args:get-arg "-m") "")) )
-
- (debug:print 0 "Listing files in " )
- (sretrieve:ls configdat user dir msg)))
+ (if (< (length args) 2)
+ (begin
+ (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
+ (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))))
+ (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
+ (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
+ (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))))
+ ;(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))))))
+ ((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)))
+ (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 area!!" )
+ (print "ERROR: Missing arguments !!" )
(exit 1))
- (sretrieve:shell (car args)))
- )
+ (sretrieve:shell (car args))))
(else (debug:print 0 "Unrecognised command " action))))
(define (main)
(let* ((args (argv))
(prog (car args))
@@ -890,30 +1050,10 @@
;; one-word commands
((eq? (length rema) 1)
(case (string->symbol (car rema))
((help -h -help --h --help)
(print sretrieve:help))
- ((list-vars) ;; print out the ini file
- (map print (sretrieve:get-areas configdat)))
- ((ls)
- (let* ((base-dir (configf:lookup configdat "settings" "base-dir")))
- (if base-dir
- (begin
- (print "Files in " base-dir)
- (sretrieve:do-as-calling-user
- (lambda ()
- (process-execute "/bin/ls" (list "-lrt" base-dir)))))
- (print "ERROR: No base dir specified!"))))
- ((log)
- (sretrieve:db-do configdat (lambda (db)
- (print "Logs : ")
- (query (for-each-row
- (lambda (row)
- (apply print (intersperse row " | "))))
- (sql db "SELECT * FROM actions")))))
- ;((shell)
- ; (sretrieve:shell))
(else
(print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
;; multi-word commands
((null? rema)(print sretrieve:help))
((>= (length rema) 2)