Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -257,15 +257,19 @@
datashare-testing/spublish : spublish.scm $(OFILES)
csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish
datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o
csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve
+
+datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o
+ csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize
+
sretrieve/sretrieve : datashare-testing/sretrieve
csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o
chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \
- srfi-1 posix regex regex-case srfi-69
+ srfi-1 posix regex regex-case srfi-69
# base64 dot-locking \
# csv-xml z3
# "(define (toplevel-command . a) #f)"
Index: datashare-testing/.sretrieve.config
==================================================================
--- datashare-testing/.sretrieve.config
+++ datashare-testing/.sretrieve.config
@@ -1,8 +1,8 @@
[settings]
base-dir /tmp/delme_data
-allowed-users matt
+allowed-users matt
allowed-chars [0-9a-zA-Z\-\.]+
allowed-sub-paths [0-9a-zA-Z\-\.]+
[database]
location #{scheme (create-directory "/tmp/#{getenv USER}" #t)}
ADDED sample-sauth-paths.scm
Index: sample-sauth-paths.scm
==================================================================
--- /dev/null
+++ sample-sauth-paths.scm
@@ -0,0 +1,4 @@
+(define *db-path* "/path/to/db")
+(define *exe-path* "/path/to/store/suids")
+(define *exe-src* "/path/to/spublish/and/sretrieve/executables")
+(define *sauth-path* "/path/to/production/sauthorize/exe")
ADDED sauth-common.scm
Index: sauth-common.scm
==================================================================
--- /dev/null
+++ sauth-common.scm
@@ -0,0 +1,263 @@
+
+;; 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
+ (debug: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)
+ (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)
+ (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
+(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) "/")))))
+ ; (print 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)))
+ #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))))))
+ )
+)))
+))))))
+
ADDED sauthorize.scm
Index: sauthorize.scm
==================================================================
--- /dev/null
+++ sauthorize.scm
@@ -0,0 +1,544 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+(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))
+(declare (uses megatest-version))
+
+(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
+ 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,
+ 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))
+
+;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)))
+ ;(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) 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)))
+ (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)
+ (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)
+ (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:grant auser guser area exp-date access-type restrict)
+ ; check if user exist
+ (let* ((area-obj (get-area area))
+ (auser-obj (get-user auser))
+ (user-obj (get-user guser)))
+
+ (if (null? user-obj)
+ (begin
+ (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)))
+ (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
+ (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))
+ (path (car args))
+ (group (or (args:get-arg "--group") ""))
+ (area (or (args:get-arg "--code") ""))
+ (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)))
+
+ (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))
+ (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)
+
+
+
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -7,10 +7,14 @@
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; 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)
@@ -18,10 +22,12 @@
;; (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:))
@@ -39,29 +45,32 @@
;; (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")
+
;;
;; 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.
Learn more at http://www.kiatoa.com/fossils/megatest
Version: " megatest-fossil-hash)) ;; "
@@ -70,10 +79,13 @@
;;======================================================================
;;======================================================================
;; DB
;;======================================================================
+
+(define *default-log-port* (current-error-port))
+(define *verbosity* 1)
(define (spublish:initialize-db db)
(for-each
(lambda (qry)
(exec (sql db qry)))
@@ -149,11 +161,11 @@
(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)
+ (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 ()
@@ -343,10 +355,332 @@
(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)
+ (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")
+ (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)))
+ ; (print ret-val)
+ 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))
+
+
+(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))
+ (print "Error: Source path " src-path " does not exist!!" ))
+ (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" "-")))))
+ (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 "ERROR: 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)
+ (if (not (file-exists? targ-path))
+ (begin
+ (print "ERROR: target path " targ-path " does not exist!!"))
+ (let* ((th1 (make-thread
+ (lambda ()
+ (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))
+ (print "ERROR: Path " sub-path " does not exist!! cannot proceed with link creation!!")
+ (begin
+ (if (not (file-exists? src-path))
+ (print "ERROR: Path " src-path " does not exist!! cannot proceed with link creation!!")
+ (begin
+ (if (file-exists? target-path)
+ (print "ERROR: 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
+ (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)
+ (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
;;======================================================================
@@ -357,148 +691,110 @@
(if (file-exists? fname)
;; (ini:read-ini fname)
(read-config fname #f #t)
(make-hash-table))))
-(define (spublish:process-action configdat 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")
- ""))))
- (if (not target-dir)
- (begin
- (print "[settings]\ntarget-dir /some/path\n\n Is MISSING from the config file!")
- (exit)))
- (if (null? allowed-users)
- (begin
- (print "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
- (exit)))
- (if (not (member user allowed-users))
- (begin
- (print "User \"" (current-user-name) "\" does not have access. Exiting")
- (exit 1)))
+(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 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 ", "))
+ (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))
- (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)))
+ (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)
@@ -506,37 +802,21 @@
(define (main)
(let* ((args (argv))
(prog (car args))
(rema (cdr args))
- (exe-name (pathname-file (car (argv))))
- (exe-dir (or (pathname-directory prog)
- (spublish:find exe-name (string-split (get-environment-variable "PATH") ":"))))
- (configdat (spublish:load-config exe-dir exe-name)))
+ (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))
- ((list-vars) ;; print out the ini file
- (map print (spublish:get-areas configdat)))
- ((ls)
- (let ((target-dir (configf:lookup configdat "settings" "target-dir")))
- (print "Files in " target-dir)
- (system (conc "ls " target-dir))))
- ((log)
- (spublish:db-do configdat (lambda (db)
- (print "Listing actions")
- (query (for-each-row
- (lambda (row)
- (apply print (intersperse row " | "))))
- (sql db "SELECT * FROM actions")))))
(else
(print "ERROR: Unrecognised command. Try \"spublish help\""))))
;; multi-word commands
((null? rema)(print spublish:help))
((>= (length rema) 2)
- (apply spublish:process-action configdat (car rema)(cdr rema)))
+ (apply spublish:process-action (car rema)(cdr rema)))
(else (print "ERROR: Unrecognised command2. Try \"spublish help\"")))))
(main)
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -7,43 +7,38 @@
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(use defstruct)
-
-;; (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 scsh-process)
+
(use srfi-18)
-(use format)
-
+(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 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)
@@ -51,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)) ;; "
@@ -94,11 +87,11 @@
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)
+ ; (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
@@ -109,15 +102,14 @@
;; (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 *default-log-port* "[database]\nlocation /some/path\n\n Is missing from the config file!")
+ (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"))
@@ -124,37 +116,37 @@
(writeable (file-write-access? dbpath))
(dbexists (file-exists? dbpath)))
(handle-exceptions
exn
(begin
- (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
+ (debug:print 2 "ERROR: problem accessing db " dbpath
((condition-property-accessor 'exn 'message) exn))
(exit 1))
- ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath )
+ ;;(debug:print 0 "calling proc " proc "db path " dbpath )
(call-with-database
dbpath
(lambda (db)
- ;;(debug:print 0 *default-log-port* "calling proc " proc " on db " 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-error 0 *default-log-port* "invalid path for storing database: " path))))
+ (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-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
+ (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
(exit 1)))
(print datadir)
(if (not (file-exists? datadir))
(begin
- (debug:print-error 0 *default-log-port* "Bad version (" version "), no data found at " datadir "." )
+ (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
(exit 1)))
(sretrieve:db-do
configdat
(lambda (db)
@@ -173,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)
@@ -187,34 +178,34 @@
(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-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
+ (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
(exit 1)))
(print datadir)
(if (not (file-exists? datadir))
(begin
- (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." )
+ (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." )
(exit 1)))
(if (directory? datadir)
(begin
- (debug:print-error 0 *default-log-port* "(" file ") is a dirctory!! cp cmd works only on files ." )
+ (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-error 0 *default-log-port* "Access denied to file (" file ")!! " )
+ (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 *default-log-port* "ph: "(pathname-directory datadir) "!! " )
+ ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " )
(change-directory (pathname-directory datadir))
- ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) )
+ ;;(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
;;
@@ -224,148 +215,44 @@
(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-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
+ (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
(exit 1)))
(print datadir)
(if (not (file-exists? datadir))
(begin
- (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." )
+ (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-error 0 *default-log-port* "Access denied to file (" file ")!! " )
+ (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
(exit 1)))
(sretrieve:do-as-calling-user
(lambda ()
- ;;(change-directory datadir)
- ;; (debug:print 0 *default-log-port* "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'"))
- ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line))))
- ;; (debug:print 0 *default-log-port* status)
(process-execute "/bin/ls" (list "-ls" "-lrt" datadir ))
))))
-;;(filter (lambda (x)
-;; (not (member x '("." ".."))))
-;; (glob "*" ".*"))))))))
-
(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-error 0 *default-log-port* "Path " targ-mk " resolved outside target area " target-dir )
+ (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-error 0 *default-log-port* "You cannot update data outside " target-dir ".")
+ (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
(exit 1)))
- (debug:print 0 *default-log-port* "Path " targ-mk " is valid.")
+ (debug:print 0 "Path " targ-mk " is valid.")
))
-;; make directory in dest
-;;
-
-(define (sretrieve:mkdir configdat submitter target-dir targ-mk comment)
- (let ((targ-path (conc target-dir "/" targ-mk)))
-
- (if (file-exists? targ-path)
- (begin
- (debug:print-error 0 *default-log-port* "target Directory " targ-path " already exist!!")
- (exit 1)))
- (sretrieve:db-do
- configdat
- (lambda (db)
- (sretrieve:register-action db "mkdir" submitter targ-mk comment)))
- (let* ((th1 (make-thread
- (lambda ()
- (create-directory targ-path #t)
- (debug:print 0 *default-log-port* " ... 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 (sretrieve:ln configdat submitter target-dir targ-link link-name comment)
- (let ((targ-path (conc target-dir "/" link-name)))
- (if (file-exists? targ-path)
- (begin
- (debug:print-error 0 *default-log-port* "target file " targ-path " already exist!!")
- (exit 1)))
- (if (not (file-exists? targ-link ))
- (begin
- (debug:print-error 0 *default-log-port* "target file " targ-link " does not exist!!")
- (exit 1)))
-
- (sretrieve:db-do
- configdat
- (lambda (db)
- (sretrieve:register-action db "ln" submitter link-name comment)))
- (let* ((th1 (make-thread
- (lambda ()
- (create-symbolic-link targ-link targ-path )
- (debug:print 0 *default-log-port* " ... 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 (sretrieve:rm configdat submitter target-dir targ-file comment)
- (let ((targ-path (conc target-dir "/" targ-file)))
- (if (not (file-exists? targ-path))
- (begin
- (debug:print-error 0 *default-log-port* "target file " targ-path " not found, nothing to remove.")
- (exit 1)))
- (sretrieve:db-do
- configdat
- (lambda (db)
- (sretrieve:register-action db "rm" submitter targ-file comment)))
- (let* ((th1 (make-thread
- (lambda ()
- (delete-file targ-path)
- (debug:print 0 *default-log-port* " ... 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 (sretrieve:backup-move path)
(let* ((trashdir (conc (pathname-directory path) "/.trash"))
(trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
(create-directory trashdir #t)
@@ -392,11 +279,11 @@
(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 *default-log-port* "running as " (current-effective-user-id))
+ ;; (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)
@@ -417,161 +304,738 @@
;;======================================================================
;; SHELL
;;======================================================================
-(define (toplevel-command . args) #f)
-(define (sretrieve: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)))
+
+
+
+;; 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
+ (print "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 (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))
+ (print "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)
+ (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
+ 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 "> ")
- (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18"))
+ (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)))
- (install-history-file) ;; [homedir] [filename] [nlines])
- (with-input-from-port iport
- (lambda ()
- (let loop ((inl (read-line)))
- (if (not (or (eof-object? inl)
- (equal? inl "exit")))
+ (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))))
- (if (not cmd)
+ ; (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
- (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths
- (set! path '())))
+ (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)
- path))
+ `()))
+ (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 (string-intersperse top-areas " ")))
- ((and (< plen 2)
- (member (car thepath) top-areas))
- (system (conc "ls /p/fdk/gwa/" (car thepath))))
- (else ;; have a long path
- ;; check for access rights here
- (system (conc "ls /p/fdk/gwa/" (string-intersperse 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)))))))))
+ (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 #t)
+ (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")))
- ;; this section here does a timestamp based rebuild of the
- ;; /.config file using
- ;; as an input
- (if (file-exists? upstream-file)
+ (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-error 0 *default-log-port* "failed to run script " conversion-script " with params " upstream-file " " package-config)
+ (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 *default-log-port* "Skipping update of " package-config " from " upstream-file))
- (debug:print 0 *default-log-port* "Skipping update of " package-config " as " upstream-file " not found"))
- ;; (ini:property-separator-patt " * *")
- ;; (ini:property-separator #\space)
- (let ((res (if (file-exists? package-config)
+ (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 *default-log-port* "Reading package config " package-config)
+ (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)
- (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
- (user (current-user-name))
- (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
- (allowed-users (string-split
- (or (configf:lookup configdat "settings" "allowed-users")
- "")))
- (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package
-
- (if (not base-dir)
- (begin
- (debug:print 0 *default-log-port* "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!")
- (exit)))
- (if (null? allowed-users)
- (begin
- (debug:print 0 *default-log-port* "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
- (exit)))
- (if (not (member user allowed-users))
- (begin
- (debug:print 0 *default-log-port* "User \"" (current-user-name) "\" does not have access. Exiting")
- (exit 1)))
+ ; (use readline)
(case (string->symbol action)
((get)
- (if (< (length args) 1)
- (begin
- (debug:print-error 0 *default-log-port* "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")))
-;; (relconfig (sretrieve:load-packages configdat exe-dir package-type)))
-
- (debug:print 0 *default-log-port* "retrieving " version " of " package-type " as tar data on stdout")
- (sretrieve:get configdat user version msg)))
- ((cp)
- (if (< (length args) 1)
- (begin
- (debug:print-error 0 *default-log-port* "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 *default-log-port* "copinging " file " to current directory " )
- (sretrieve:cp configdat user file msg)))
- ((ls)
- (if (< (length args) 1)
- (begin
- (debug:print-error 0 *default-log-port* "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 *default-log-port* "Listing files in " )
- (sretrieve:ls configdat user dir msg)))
-
- (else (debug:print 0 *default-log-port* "Unrecognised command " action)))))
-
-;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
-;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc")))
-;; (if (file-exists? debugcontrolf)
-;; (load debugcontrolf)))
+ (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 !!" )
+ (exit 1))
+ (sretrieve:shell (car args))))
+ (else (debug:print 0 "Unrecognised command " action))))
(define (main)
(let* ((args (argv))
(prog (car args))
(rema (cdr args))
@@ -586,34 +1050,17 @@
;; 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)
(apply sretrieve:process-action configdat (car rema)(cdr rema)))
- (else (debug:print-error 0 *default-log-port* "Unrecognised command. Try \"sretrieve help\"")))))
+ (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))
(main)
+
+
+