Index: sauth-common.scm
==================================================================
--- sauth-common.scm
+++ sauth-common.scm
@@ -16,11 +16,11 @@
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 )
+ ;(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
@@ -28,10 +28,11 @@
(proc db)))))
(print 0 "ERROR: invalid path for storing database: " *db-path*)))
;;execute a query
(define (sauthorize:db-qry db qry)
+ ;(print qry)
(exec (sql db qry)))
(define (sauthorize:do-as-calling-user proc)
(let ((eid (current-effective-user-id))
Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ sauthorize.scm
@@ -41,10 +41,11 @@
log : get listing of recent activity.
sauth list-area-user : list the users that can access the area.
sauth open --group : Open up an area. User needs to be the owner of the area to open it.
--code
--retrieve|--publish
+ sauth open --retrieve|--publish : update the binaries with the lates changes
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.
@@ -299,10 +300,36 @@
(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:update username exe area access-type)
+ (let* ((parts (string-split exe "_"))
+ (owner (car parts))
+ (group (cadr parts))
+ (gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (not (equal? username owner))
+ (begin
+ (print "You cannot update " area ". Only " owner " can update this area!!")
+ (exit 1)))
+ (copy-exe access-type exe group)
+ (print "recording action..")
+ (sauthorize:db-do (lambda (db)
+
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
+ (print "Area has " area " been update!!" )))
(define (sauthorize:grant auser guser area exp-date access-type restrict)
; check if user exist in db
(let* ((area-obj (get-area area))
(auser-obj (get-user auser))
@@ -476,10 +503,28 @@
(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)))
+ ((update)
+ (if (< (length args) 2)
+ (begin
+ (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update --retrieve|--publish")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area))
+ (access-type (get-access-type (cdr args))))
+ (if (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
+ (begin
+ (print "Access type can be --retrieve|--publish ")
+ (exit 1)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) access-type)))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:update username (cadr code-obj) area access-type )))
((area-admin)
(let* ((usr (car args))
(usr-obj (get-user usr))
(user-id (car (get-user username))))
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -48,11 +48,12 @@
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
(include "sauth-common.scm")
-
+(define (toplevel-command . args) #f)
+(use readline)
;;
;; GLOBALS
;;
(define *spublish:current-tab-number* 0)
@@ -456,31 +457,38 @@
(thread-start! th2)
(thread-join! th1)
(cons #t "Successfully saved data"))))
-(define (spublish:shell-rm targ-path)
+(define (spublish:shell-rm targ-path iport)
(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)))
+ (begin
+ (print "Are you sure you want to delete " targ-path "?[y/n]")
+ (let* ((inl (read-line iport)))
+ (if (equal? inl "y")
+ (let* ((th1 (make-thread
+ (lambda ()
+ ;(print "hi")
+ (if (directory? targ-path)
+ (delete-directory targ-path #t)
+ (delete-file targ-path ))
+ (print " ... path " targ-path " deleted"))
+ "rm thread"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 15)
+ (display ".")
+ (flush-output)
+ (loop)))
"action is happening thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- (cons #t "Successfully saved data"))))
+ (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
@@ -512,10 +520,11 @@
(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))
@@ -618,11 +627,11 @@
(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)
+ (spublish:shell-rm target-path iport)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))
)))))
@@ -776,16 +785,18 @@
(print "ERROR: Missing arguments; ")
(exit 1)))
(let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
(rm-path (car filter-args))
(resolved-path (sauth-common:resolve-path rm-path (list area) top-areas))
+ (prompt ">")
+ (iport (make-readline-port prompt))
(target-path (sauth-common:get-target-path (list area) rm-path top-areas base-path)))
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " rm-path ".. ")
(begin
- (spublish:shell-rm target-path)
+ (spublish:shell-rm target-path iport)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))))
((shell)
(if (< (length args) 1)