Index: sample-sauth-paths.scm ================================================================== --- sample-sauth-paths.scm +++ sample-sauth-paths.scm @@ -1,3 +1,4 @@ (define *db-path* "/path/to/db") -(define *exe-path* "/tmp/to/store/suids") +(define *exe-path* "/path/to/store/suids") (define *exe-src* "/path/to/spublish/and/sretrieve/executables") +(define *sauth-path* "/path/to/production/sauthorize/exe") Index: sauth-common.scm ================================================================== --- sauth-common.scm +++ sauth-common.scm @@ -42,13 +42,32 @@ (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) @@ -56,28 +75,58 @@ (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)) - (let* ((access-type (car 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 "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) @@ -112,6 +161,103 @@ (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)))))) + ) +))) +)))))) Index: sauthorize.scm ================================================================== --- sauthorize.scm +++ sauthorize.scm @@ -111,42 +111,36 @@ "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)))))) -(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-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) @@ -157,27 +151,10 @@ (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))) @@ -191,12 +168,16 @@ (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)))) + (if (equal? access-type "publish") + (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) + (begin + (run-cmd "/bin/chgrp" (list group dpath)) + (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath)))) +)) (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type))))) (define (get-exe-name path group) (let ((name "")) (sauthorize:do-as-calling-user @@ -242,26 +223,22 @@ (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) +(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)) -(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))) @@ -284,13 +261,14 @@ (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) + (if (user-has-open-perm user path access-type) (begin (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) @@ -314,11 +292,11 @@ ;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) ))) + (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) @@ -365,13 +343,13 @@ (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!")))) + + (sauthorize:list-areausers area ) + )) ((read-shell) (if (not (equal? (length args) 1)) (begin (print "Missing argument area code to read-shell ") (exit 1))) @@ -382,11 +360,11 @@ (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" )))))) + (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))) @@ -397,11 +375,11 @@ (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" )))))) + (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area)))))) ((open) (if (< (length args) 6) (begin @@ -420,17 +398,36 @@ (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")) + ((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))) - (else (debug:print 0 "Unrecognised command " action)))) + (sauthorize:open username path group area access-type))) + ((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)) 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,33 @@ ;; (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 + cp|publish : copy file to target area mkdir : maks directory in target area rm : remove file from target area ln : creates a symlink log : 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 +80,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 +162,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 +356,331 @@ (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" "-"))))))) + (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" "-"))) + )))))))) + + +(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,28 +691,18 @@ (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")) +(define (spublish:process-action action . args) + (let* ( + ;; (target-dir (configf:lookup configdat "settings" "target-dir")) (user (current-user-name)) - (allowed-users (string-split - (or (configf:lookup configdat "settings" "allowed-users") - "")))) - (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))) + ;;(allowed-users (string-split + ;; (or (configf:lookup configdat "settings" "allowed-users") + ;; ""))) +) (case (string->symbol action) ((cp publish) (if (< (length args) 2) (begin (print "ERROR: Missing arguments; " (string-intersperse args ", ")) @@ -495,10 +819,18 @@ (vector-ref x 2) (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") (conc "\"" (vector-ref x 4) "\"")) (print (vector-ref x 0)))) versions))) + ((shell) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments area!!" ) + (exit 1)) + (spublish:shell (car args))) + ) + (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 +838,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 @@ -45,10 +45,13 @@ ;; (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 *verbosity* 1) @@ -353,98 +356,55 @@ (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 ))) +(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 (sretrieve:get-target-path base-path-list ext-path top-areas configfile))) - ;(print "Resolved path: " target-path) + (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path))) + (print "Resolved path: " target-path) (if (not (equal? target-path #f)) (begin - - (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) "|")) @@ -453,26 +413,22 @@ (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 )) +(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 (sretrieve:get-target-path base-pathlist ext-path top-areas configfile))) + (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 "cat" (current-user-name) target-path (conc "Executing cmd: cat " target-path)))) - (cond + (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!!")) @@ -496,40 +452,30 @@ (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 )) +(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 "grep cmd cannot accept > " (string-join redirect-split) " as an argument!!" ) + (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 (sretrieve:get-target-path base-pathlist ext-path top-areas configfile)) + (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-pathlist ext-path top-areas configfile))) + (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 - (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))) @@ -547,60 +493,36 @@ (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 ))) +(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 (sretrieve:get-target-path base-pathlist ext-path top-areas configfile))) + (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)))) + ;(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: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) @@ -627,38 +549,76 @@ ((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) +(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 - (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) + (if (is_directory target-path) (begin (let* ((parent-dir target-path) - (start-dir (current-directory)) + (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 ",")))) - (change-directory parent-dir) - - (run (pipe - (tar "chfv" "-" "." ) - (begin (system (conc "cd " start-dir ";tar xf - " execlude ))))) - )) + (print execlude) + (print (file-exists? start-dir)) + (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) + (run (pipe + (tar "chfv" "-" "." ) + (begin (system (conc "cd " start-dir ";tar xUf - " execlude ))))) + (change-directory curr-dir)) + (begin + (print "Nothing has been retrieved!! "))))) + (begin + (sretrieve:do-as-calling-user + (lambda () + (create-directory start-dir #t))) + (change-directory parent-dir) + (run (pipe + (tar "chfv" "-" "." ) + (begin (system (conc "cd " start-dir ";tar xUf - " execlude ))))) + (change-directory curr-dir))))) (begin (let*((parent-dir (pathname-directory target-path)) - (start-dir (current-directory)) - (filename (if (pathname-extension 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)))) + (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" "-" "." ) + (begin (system (conc "cd " start-dir ";tar xUf - " execlude ))))) + (change-directory curr-dir)) + (begin + (print "Nothing has been retrieved!! "))))) + (begin (change-directory parent-dir) (run (pipe (tar "chfv" "-" ,filename) - (begin (system (conc "cd " start-dir ";tar xf -"))))))))))) + (begin (system (conc "cd " start-dir ";tar xUf -"))))) + (change-directory start-dir)))))))) + (print (current-directory))))) (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 @@ -673,49 +633,54 @@ 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)) +(define (sretrieve:shell area) + ; (print area) (use readline) (let* ((path '()) (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) + (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 () + (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)))) + ; (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 (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))) + (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 ".. ") - (set! path resolved-path))))) + (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 "/")))) @@ -722,32 +687,50 @@ ((ls) (let* ((thepath (if (> (length parts) 1) ;; have a parameter (cdr parts) `())) (plen (length thepath))) - (cond + (cond ((null? thepath) - (sretrieve:shell-ls-cmd path "" top-areas config-file db-location '())) + (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) - (sretrieve:shell-ls-cmd path (car thepath) top-areas config-file db-location '())) + + (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) "|") - (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))))))) + (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 config-file db-location '())) + (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 config-file db-location (cdr thepath)))))) - ((grep) + (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 @@ -754,52 +737,56 @@ ((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 config-file db-location (cdr thepath)))))) + (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 cat")) + (print "Error: Missing argument to less")) ((< plen 2) - (sretrieve:shell-less-cmd path (car thepath) top-areas config-file db-location)) + (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 - ;(sretrieve:shell-cat-cmd path (car thepath) top-areas config-file)) -)))) - + (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 "Error: Missing argument to get")) ((< plen 2) - (let* ((target-path (sretrieve:get-target-path path (car thepath) top-areas config-file)) + (let* ((target-path (sauth-common:get-target-path path (car thepath) top-areas base-path)) (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) - )) + (sretrieve:shell-lookup base-path)))) + (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 "))))) + (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 iport)) - ))))) + (print "Got command: " inl)))) + (loop (read-line iport))))))) ;;)) ;;====================================================================== ;; MAIN @@ -822,14 +809,11 @@ (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 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) @@ -844,30 +828,10 @@ (make-hash-table)))) (pop-directory) res))) (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 "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") - (exit))) - (if (null? allowed-users) - (begin - (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 "User \"" (current-user-name) "\" does not have access. Exiting") - (exit 1))) (case (string->symbol action) ((get) (if (< (length args) 1) (begin (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) @@ -876,12 +840,10 @@ (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 "retrieving " version " of " package-type " as tar data on stdout") (sretrieve:get configdat user version msg))) ((cp) (if (< (length args) 1) (begin @@ -902,17 +864,18 @@ (dir (car args)) (msg (or (args:get-arg "-m") "")) ) (debug:print 0 "Listing files in " ) (sretrieve:ls configdat user dir msg))) - - (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))) + ((shell) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments area!!" ) + (exit 1)) + (sretrieve:shell (car args))) + ) + (else (debug:print 0 "Unrecognised command " action)))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) @@ -945,12 +908,12 @@ (print "Logs : ") (query (for-each-row (lambda (row) (apply print (intersperse row " | ")))) (sql db "SELECT * FROM actions"))))) - ((shell) - (sretrieve:shell)) + ;((shell) + ; (sretrieve:shell)) (else (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) ;; multi-word commands ((null? rema)(print sretrieve:help)) ((>= (length rema) 2)