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-chars [0-9a-zA-Z\-\.]+ - +allowed-sub-paths [0-9a-zA-Z\-\.]+ [database] location #{scheme (create-directory "/tmp/#{getenv USER}" #t)} Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -54,11 +54,11 @@ (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] ls : list contents of target area get : retrieve data for release -m \"message\" : why retrieved? - + cp : copy file to current directory log : get listing of recent downloads Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest @@ -108,10 +108,11 @@ ;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout ;; ...)) ;; Create the sqlite db (define (sretrieve:db-do configdat proc) + (let ((path (configf:lookup configdat "database" "location"))) (if (not path) (begin (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") (exit 1))) @@ -125,20 +126,21 @@ 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) + ;;(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)))) -;; copy in file to dest, validation is done BEFORE calling this +;; 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) @@ -156,16 +158,97 @@ configdat (lambda (db) (sretrieve:register-action db "get" retriever datadir comment))) (sretrieve:do-as-calling-user (lambda () - (change-directory datadir) - (let ((files (filter (lambda (x) + (if (directory? datadir) + (begin + (change-directory datadir) + (let ((files (filter (lambda (x) (not (member x '("." "..")))) (glob "*" ".*")))) - (print "files: " files) - (process-execute "/bin/tar" (append (list "chfv" "-") files))))))) + (print "files: " files) + (process-execute "/bin/tar" (append (list "chfv" "-") files)))) + (begin + (let* ((parent-dir (pathname-directory datadir) ) + (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) + (change-directory parent-dir) + (process-execute "/bin/tar" (list "chfv" "-" filename)) + ))) +)) +)) + + +;; copy in file to dest, validation is done BEFORE calling this +;; +(define (sretrieve:cp configdat retriever file comment) + (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) + (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 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (exit 1))) + (print datadir) + (if (not (file-exists? datadir)) + (begin + (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) + (exit 1))) + (if (directory? datadir) + (begin + (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 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 "ph: "(pathname-directory datadir) "!! " ) + (change-directory (pathname-directory datadir)) + ;;(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 +;; +(define (sretrieve:ls configdat retriever file comment) + (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) + (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 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (exit 1))) + (print datadir) + (if (not (file-exists? datadir)) + (begin + (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 0 "ERROR: Access denied to file (" file ")!! " ) + (exit 1))) + + (sretrieve:do-as-calling-user + (lambda () + ;;(change-directory datadir) + ;; (debug:print 0 "/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 status) + (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) + )))) + + ;;(filter (lambda (x) ;; (not (member x '("." "..")))) ;; (glob "*" ".*")))))))) @@ -376,10 +459,11 @@ 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 @@ -409,10 +493,33 @@ (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 + (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) + (file (car args)) + (msg (or (args:get-arg "-m") "")) ) + + (debug:print 0 "copinging " file " to current directory " ) + (sretrieve:cp configdat user file msg))) + ((ls) + (if (< (length args) 1) + (begin + (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) + (dir (car args)) + (msg (or (args:get-arg "-m") "")) ) + + (debug:print 0 "Listing files in " ) + (sretrieve:ls configdat user dir msg))) + (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) @@ -442,11 +549,11 @@ (if base-dir (begin (print "Files in " base-dir) (sretrieve:do-as-calling-user (lambda () - (process-execute "/bin/ls" (list base-dir))))) + (process-execute "/bin/ls" (list "-lrt" base-dir))))) (print "ERROR: No base dir specified!")))) ((log) (sretrieve:db-do configdat (lambda (db) (print "Logs : ") (query (for-each-row