Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -218,15 +218,19 @@
datashare-testing/spublish : spublish.scm $(OFILES)
csc spublish.scm $(OFILES) -o datashare-testing/spublish
datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o
csc 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 -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.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,3 @@
+(define *db-path* "/path/to/db")
+(define *exe-path* "/tmp/to/store/suids")
+(define *exe-src* "/path/to/spublish/and/sretrieve/executables")
ADDED sauth-common.scm
Index: sauth-common.scm
==================================================================
--- /dev/null
+++ sauth-common.scm
@@ -0,0 +1,117 @@
+
+;; 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))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; 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 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))
+ (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")))))))
+has-access))
+
+;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))
+
ADDED sauthorize.scm
Index: sauthorize.scm
==================================================================
--- /dev/null
+++ sauthorize.scm
@@ -0,0 +1,475 @@
+
+;; 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.
+ sauthorize list-area-user <area code> : list the users that can access the area.
+ sauthorize open <path> --group <grpname> : Open up an area. User needs to be the owner of the area to open it.
+ --code <unique short identifier for an area>
+ --retrieve|--publish
+ sauthorize grant <username> --area <area identifier> : Grant permission to read or write to a area that is alrady opend up.
+ --expiration yyyy/mm/dd --retrieve|--publish
+ [--restrict <comma separated directory names> ]
+ sauthorize read-shell <area identifier> : Open sretrieve shell for reading.
+ sauthorize write-shell <area identifier> : 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")
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+
+(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 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-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)
+ (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 "'"))))))
+
+
+
+
+
+(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))))
+obj))
+
+
+
+; 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 ))
+ (run-cmd "/bin/chgrp" (list group dpath))
+ (run-cmd "/bin/chmod" (list "u+s,g+s" 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)))
+ (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
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') "))))))))
+
+(define (user-has-open-perm user path)
+ (let* ((has-access #f)
+ (eid (current-user-id)))
+ (cond
+ ((is-admin user)
+ (set! has-access #t ))
+ (else
+ (print "User " user " does not have permission to open areas")))
+ has-access))
+
+(define (run-cmd cmd arg-list)
+ (handle-exceptions
+ exn
+ (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
+ (let ((pid (process-run cmd arg-list)))
+ (process-wait pid))))
+
+;;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* ((req_grpid (caddr (group-information group)))
+ (current-grp-list (get-groups))
+ (valid-grp (is-group-washed req_grpid current-grp-list)))
+ (if (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)
+ (begin
+ (open-area group path code access-type)
+ (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)))
+ (if (can-grant-perm username "retrieve" area)
+ (sauthorize:list-areausers area )
+ (print "User does not have access to run this cmd!"))))
+ ((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" ))))))
+ ((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 reading!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" ))))))
+
+
+ ((open)
+ (if (< (length args) 6)
+ (begin
+ (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --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))
+ ((or (equal? access-type "area-admin")
+ (equal? access-type "writer-admin"))
+ (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+
+ (sauthorize:open username path group area access-type)))
+ (else (debug: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: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -7,10 +7,11 @@
;; 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 ssax)
;; (use sxml-serializer)
;; (use sxml-modifications)
;; (use regex)
@@ -19,18 +20,22 @@
;; (use posix)
;; (use json)
;; (use csv)
;; (use directory-utils)
(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))
@@ -94,11 +99,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
@@ -113,11 +118,11 @@
(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 +129,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)
@@ -187,34 +192,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 +229,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 +293,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,66 +318,508 @@
;;======================================================================
;; 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 sheet configfile)
+ (let* ((users (get-rowcol-names configfile sheet car))
+ (retuser ""))
+ (if (member (current-user-name) users)
+ #t
+ #f)))
+
+ ;; function to check if user is trying to access a restricted area
+
+(define (sretrieve:is-permitted-area dir allowed-list)
+ (for-each
+ (lambda (allowed-dir)
+ (if (equal? dir allowed-dir)
+ allowed-dir))
+ (cdr allowed-list)))
+
+;; function to validate the users input for target path and resolve the path
+;; TODO: Check for restriction in subpath
+(define (sretrieve: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 "/"))
+ ;(sheet (car normal-list))
+ (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 (sretrieve:is-access-valid sheet configfile)
+ (let* ((exp-str (lookup configfile sheet (current-user-name) "expiration")))
+ (if (equal? exp-str #f)
+ #f
+ (let* ((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 )))
+ (if (< (date-compare exp-date (current-date)) 1)
+ #f
+ #t)))))
+
+
+(define (sretrieve:get-accessable-projects sheets configfile)
+ ;;(print sheets)
+ (if (null? sheets)
+ #f
+ (let loop ((hed (car sheets))
+ (tal (cdr sheets))
+ (res '()))
+ (let* ((user (sretrieve:has-permission hed configfile))
+ (access-valid (sretrieve:is-access-valid hed configfile)))
+ (if (and (equal? user #t ) (equal? access-valid #t))
+ (begin
+ ;;(print "got perm " (sretrieve:has-permission hed configfile))
+ (if (null? tal)
+ (cons hed res)
+ (loop (car tal)(cdr tal)(cons hed res))))
+ (if (null? tal)
+ res
+ (loop (car tal)(cdr tal) res)))))))
+
+(define (sretrieve:shell-ls-cmd base-path-list ext-path top-areas configfile db-location tail-cmd-list)
+ (if (and (null? base-path-list) (equal? ext-path "") )
+ (print (string-intersperse top-areas " "))
+ (let* ((resolved-path (sretrieve:resolve-path ext-path base-path-list top-areas )))
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print (string-intersperse top-areas " "))
+ (let* ((target-path (sretrieve:get-target-path base-path-list ext-path top-areas configfile)))
+ ;(print "Resolved path: " target-path)
+ (if (not (equal? target-path #f))
+ (begin
+
+ (sretrieve:shell-db-do
+ db-location
+ (lambda (db)
+ (sretrieve:register-action db "ls" (current-user-name) target-path (conc "Executing cmd: ls " target-path))))
+ (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 configfile db-location tail-cmd-list)
+ (let* ((resolved-path (sretrieve: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 (sretrieve:get-target-path base-pathlist ext-path top-areas configfile)))
+ (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 "cat" (current-user-name) target-path (conc "Executing cmd: cat " target-path))))
+ (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 configfile db-location tail-cmd-list)
+ (let* ((resolved-path (sretrieve: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 "grep 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 (sretrieve:get-target-path base-pathlist ext-path top-areas configfile))
+ (restrictions (if (equal? target-path #f)
+ ""
+ (sretrieve:shell-lookup base-pathlist ext-path top-areas configfile)))
+ (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
+ (sretrieve:shell-db-do
+ db-location
+ (lambda (db)
+ (sretrieve:register-action db "grep" (current-user-name) target-path (conc "Executing cmd: grep " target-path pattern (string-join tail-cmd-list) ))))
+ ; (sretrieve:do-as-calling-user
+ ; (lambda ()
+ ; (if (null? pipe-cmd)
+ ; (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))
+ ; (process-execute "/usr/bin/grep" (append (append (list options pattern target-path) rest-str) (append (list "|") pipe-cmd))))))
+ ; (print rest-str)
+ (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 configfile db-location)
+ (let* ((resolved-path (sretrieve: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 (sretrieve:get-target-path base-pathlist ext-path top-areas configfile)))
+ (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:get-target-path base-path-list ext-path top-areas configfile)
+ (let* ((resolved-path (sretrieve: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))
+ (fname (conc configfile "/" sheet ".dat"))
+ (config-data (sretrieve:load-shell-config fname))
+ (base-path (configf:lookup config-data "basepath" usr))
+ (restrictions (conc ".*" (string-join (string-split (configf:lookup config-data "restricted areas" usr) ",") ".*|.*") ".*"))
+ (target-path (conc base-path "/" (string-join (cdr resolved-path) "/"))))
+
+ (if (string-match (regexp restrictions) target-path)
+ (begin
+ (print "Access denied to " (string-join resolved-path "/"))
+ #f)
+ target-path)))
+ #f)))
+
+(define (sretrieve:shell-lookup base-path-list ext-path top-areas configfile)
+ (let* ((resolved-path (sretrieve:resolve-path ext-path base-path-list top-areas ))
+ (usr (current-user-name))
+ (sheet (car resolved-path))
+ (fname (conc configfile "/" sheet ".dat"))
+ (config-data (sretrieve:load-shell-config fname))
+ (base-path (configf:lookup config-data "basepath" usr))
+ (value (configf:lookup config-data "restricted areas" 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 " --exclude='*" hed "*'"))
+ (else
+ (loop (car tal)(cdr tal)(conc ret-str " --exclude='*" hed "*'")))))) )
+
+(define (sretrieve:get-shell-cmd target-path db-location restrictions)
+ (if (not (equal? target-path #f))
+ (begin
+ (sretrieve:shell-db-do
+ db-location
+ (lambda (db)
+ (sretrieve:register-action db "get" (current-user-name) target-path (conc "Executing cmd: get " target-path))))
+ (if (is_directory target-path)
+ (begin
+ (let* ((parent-dir target-path)
+ (start-dir (current-directory))
+ (execlude (make-exclude-pattern (string-split restrictions ","))))
+ (change-directory parent-dir)
+
+ (run (pipe
+ (tar "chfv" "-" "." )
+ (begin (system (conc "cd " start-dir ";tar xf - " execlude )))))
+ ))
+ (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))))
+ (change-directory parent-dir)
+ (run (pipe
+ (tar "chfv" "-" ,filename)
+ (begin (system (conc "cd " start-dir ";tar xf -")))))))))))
+
+(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 <path> | grep txt
+ cd <target directory> : To change the current directory within the sretrive shell.
+ pwd : Prints the full pathname of the current directory within the sretrive shell.
+ get <file or directory path> : download directory/files into the directory where sretrieve shell cmd was invoked
+ less <file path> : Read input file to allows backward movement in the file as well as forward movement
+ cat <file path> : show the contents of a file. The output of the cmd can be piped into other system cmd.
+
+ sgrep <search path> <pattern> [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)
+ ;; (print (current-effective-user-id))
(use readline)
(let* ((path '())
- (prompt "> ")
- (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18"))
+ (prompt "sretrieve> ")
+ (args (argv))
+ (usr (current-user-name) )
+ (prog (car args))
+ (exe-name (pathname-file (car (argv))))
+ (exe-dir (or (pathname-directory prog)
+ (sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":"))))
+ (config-file (conc exe-dir "/sretrieve_configs"))
+ (db-location (conc exe-dir "/db"))
+ (sheets (list-sheets config-file))
+ (top-areas (sretrieve:get-accessable-projects sheets config-file))
+
+ (close-port #f)
(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")))
+ ; (install-history-file) ;; [homedir] [filename] [nlines])
+ ; (with-input-from-port iport
+ ; (lambda ()
+ (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 (not cmd)
+ (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 (sretrieve:resolve-path arg path top-areas))
+ (target-path (sretrieve:get-target-path path arg top-areas config-file)))
+ (if (not (equal? target-path #f))
+ (if (or (equal? resolved-path #f) (not (file-exists? target-path)))
+ (print "Invalid argument " arg ".. ")
+ (set! path resolved-path)))))
+ (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)
+ (sretrieve:shell-ls-cmd path "" top-areas config-file db-location '()))
+ ((< plen 2)
+ (sretrieve:shell-ls-cmd path (car thepath) top-areas config-file db-location '()))
+ (else
+ (if (equal? (car thepath) "|")
+ (sretrieve:shell-ls-cmd path "" top-areas config-file db-location thepath)
+ (sretrieve:shell-ls-cmd path (car thepath) top-areas config-file db-location (cdr thepath)))))))
+ ((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 config-file db-location '()))
+ (else
+ (sretrieve:shell-cat-cmd path (car thepath) top-areas config-file db-location (cdr thepath))))))
+ ((grep)
+ (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 <search path> <pattern> [options] "))
+ ((< plen 2)
+ (print "Error: Missing arguments to grep!! Useage: grep <search path> <pattern> [options] "))
+ (else
+ (sretrieve:shell-grep-cmd path (car thepath) top-areas config-file db-location (cdr thepath))))))
+
+ ((less)
+ (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-less-cmd path (car thepath) top-areas config-file db-location))
+ (else
+ ;(sretrieve:shell-cat-cmd path (car thepath) top-areas config-file))
+))))
+
+ ((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 <path> to get"))
+ ((< plen 2)
+ (let* ((target-path (sretrieve:get-target-path path (car thepath) top-areas config-file))
+ (restrictions (if (equal? target-path #f)
+ ""
+ (sretrieve:shell-lookup path (car thepath) top-areas config-file))))
+
+ (sretrieve:get-shell-cmd target-path db-location restrictions)
+ ;;(print path)
+ ))
+ (else
+ (print "Error: get cmd takes only one argument ")))))
+ ((help)
+ (print (sretrieve:shell-help)))
(else
- (print "Got command: " inl))))
- (loop (read-line)))))))))
+ (print "Got command: " inl)
+ )))
+ (loop (read-line iport))
+ )))))
+;;))
;;======================================================================
;; MAIN
;;======================================================================
+;;(define *default-log-port* (current-error-port))
(define (sretrieve:load-config exe-dir exe-name)
(let* ((fname (conc exe-dir "/." exe-name ".config")))
;; (ini:property-separator-patt " * *")
;; (ini:property-separator #\space)
(if (file-exists? fname)
;; (ini:read-ini fname)
- (read-config fname #f #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"))
@@ -487,20 +830,18 @@
(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)))
@@ -513,60 +854,60 @@
"")))
(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!")
+ (debug:print 0 "[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!")
+ (debug:print 0 "[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")
+ (debug:print 0 "User \"" (current-user-name) "\" does not have access. Exiting")
(exit 1)))
(case (string->symbol action)
((get)
(if (< (length args) 1)
(begin
- (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
+ (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
(exit 1)))
(let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
(version (car args))
(msg (or (args:get-arg "-m") ""))
(package-type (or (args:get-arg "-package")
default-area))
(exe-dir (configf:lookup configdat "exe-info" "exe-dir")))
;; (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")
+ (debug:print 0 "retrieving " version " of " package-type " as tar data on stdout")
(sretrieve:get configdat user version msg)))
((cp)
(if (< (length args) 1)
(begin
- (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
+ (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
(exit 1)))
(let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
(file (car args))
(msg (or (args:get-arg "-m") "")) )
- (debug:print 0 *default-log-port* "copinging " file " to current directory " )
+ (debug:print 0 "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 ", "))
+ (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
(exit 1)))
(let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
(dir (car args))
(msg (or (args:get-arg "-m") "")) )
- (debug:print 0 *default-log-port* "Listing files in " )
+ (debug:print 0 "Listing files in " )
(sretrieve:ls configdat user dir msg)))
- (else (debug:print 0 *default-log-port* "Unrecognised command " action)))))
+ (else (debug:print 0 "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)))
@@ -612,8 +953,11 @@
(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)
+
+
+