Overview
| Comment: | sauth update |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | sauth-testing-chicken5 |
| Files: | files | file ages | folders |
| SHA1: |
0af9864a9574ee64b1217e0a383255ef |
| User & Date: | pjhatwal on 2019-06-21 11:37:33 |
| Other Links: | branch diff | manifest | tags |
Context
|
2019-06-21
| ||
| 11:37 | sauth update Leaf check-in: 0af9864a95 user: pjhatwal tags: sauth-testing-chicken5 | |
|
2019-06-19
| ||
| 10:49 | Changed the word failed to unable in message to aleviate need to add logpro rule check-in: b129805ac8 user: mrwellan tags: v1.65 | |
Changes
Modified sauth-common.scm from [28ffd8e69e] to [29d676d589].
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
(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 "/"))
| > > > > > > > > > > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
(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))
(define (sauth-common:src-size path)
(let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path " | awk '{print $1}'")
(lambda()
(read-line)))))
(string->number output)))
(define (sauth-common:space-left-at-dest path)
(let* ((output (run/string (pipe (df ,path ) (tail -1))))
(size (caddr (string-split output " "))))
(string->number size)))
;; 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 "/"))
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
base-path
(conc base-path "/" (string-join (cdr resolved-path) "/")))))
(if (and (not (equal? restricted-areas "" ))
(string-match (regexp restrictions) target-path))
(begin
| | | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
base-path
(conc base-path "/" (string-join (cdr resolved-path) "/")))))
(if (and (not (equal? restricted-areas "" ))
(string-match (regexp restrictions) target-path))
(begin
(sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
;(exit 1)
#f)
target-path)
))
#f)))
|
| ︙ | ︙ |
Modified spublish.scm from [f88672550b] to [f826faecc2].
| ︙ | ︙ | |||
391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
(define (spublish:shell-cp src-path target-path)
(cond
((not (file-exists? target-path))
(sauth:print-error (conc " target Directory " target-path " does not exist!!")))
((not (file-exists? src-path))
(sauth:print-error (conc "Source path " src-path " does not exist!!" )))
(else
(if (is_directory src-path)
(begin
(let* ((parent-dir src-path)
(start-dir target-path))
(run (pipe
(begin (system (conc "cd " parent-dir " ;tar chf - ." )))
(begin (change-directory start-dir)
| > > > > > | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
(define (spublish:shell-cp src-path target-path)
(cond
((not (file-exists? target-path))
(sauth:print-error (conc " target Directory " target-path " does not exist!!")))
((not (file-exists? src-path))
(sauth:print-error (conc "Source path " src-path " does not exist!!" )))
(else
(if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
(begin
(sauth:print-error "Error: Destination does not have enough disk space.")
(exit 1)))
(if (is_directory src-path)
(begin
(let* ((parent-dir src-path)
(start-dir target-path))
(run (pipe
(begin (system (conc "cd " parent-dir " ;tar chf - ." )))
(begin (change-directory start-dir)
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 |
(read-line))))
(msg (or (args:get-arg "-m") ""))
(resolved-path (sauth-common:resolve-path (conc area "/" dest-path) `() top-areas))
(target-path (sauth-common:get-target-path `() (conc area "/" dest-path) top-areas base-path)))
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " dest-path ".. ")
| | | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
(read-line))))
(msg (or (args:get-arg "-m") ""))
(resolved-path (sauth-common:resolve-path (conc area "/" dest-path) `() top-areas))
(target-path (sauth-common:get-target-path `() (conc area "/" dest-path) top-areas base-path)))
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " dest-path ".. ")
(begin
(spublish:shell-cp src-path target-path)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp")))))))))
((mkdir)
(if (< (length remargs) 1)
(begin
(print "ERROR: Missing arguments; <area> <path>")
(exit 1)))
(let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
(mk-path (car filter-args))
(msg (or (args:get-arg "-m") ""))
(resolved-path (sauth-common:resolve-path mk-path (list area) top-areas))
(target-path (sauth-common:get-target-path (list area) mk-path top-areas base-path)))
(print "attempting to create directory " mk-path )
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " mk-path ".. ")
(begin
(spublish:shell-mkdir target-path)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir")))))))))
((ln)
(if (< (length remargs) 2)
(begin
|
| ︙ | ︙ |