Overview
Comment: | cherrypicked changes from 1.65-archive |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.6569-pjhatwal-mess |
Files: | files | file ages | folders |
SHA1: |
b72620bfbb228166e8d799f1e7d9b383 |
User & Date: | pjhatwal on 2021-01-08 12:12:37 |
Other Links: | branch diff | manifest | tags |
Context
2021-01-08
| ||
13:31 | cherrypicked changes from 1.65-archive Leaf check-in: 0b8d6c2593 user: pjhatwal tags: v1.6569-refactor-archive-structure-change | |
12:12 | cherrypicked changes from 1.65-archive Leaf check-in: b72620bfbb user: pjhatwal tags: v1.6569-pjhatwal-mess | |
11:42 | enable custom value for max delay between archive time and test last update time Leaf check-in: 86a3d1148e user: pjhatwal tags: v1.6569-refactor | |
Changes
Modified archive.scm from [a5f3e3b4ad] to [35b9e5966e].
︙ | ︙ | |||
118 119 120 121 122 123 124 | (let ((res (cons block-id archive-path))) (hash-table-set! blockid-cache key res) res) (begin (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path) #f))) (begin | | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | (let ((res (cons block-id archive-path))) (hash-table-set! blockid-cache key res) res) (begin (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path) #f))) (begin (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ) #f)))))) ;; no best disk found ;; archive - run bup ;; ;; 1. create the bup dir if not exists ;; 2. start the du of each directory ;; 3. gen index |
︙ | ︙ | |||
222 223 224 225 226 227 228 | (toplevel/children (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) ((not (common:file-exists? test-path)) (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | (toplevel/children (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) ((not (common:file-exists? test-path)) (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else (debug:print 2 *default-log-port* "From test-dat=" test-dat " derived the following:\n" "test-partial-path = " test-partial-path "\n" "test-path = " test-path "\n" "test-physical-path = " test-physical-path "\n" "partial-path-index = " partial-path-index "\n" "test-base = " test-base) (hash-table-set! disk-groups test-base |
︙ | ︙ | |||
266 267 268 269 270 271 272 | (create-directory archive-dir #t)) (case archiver ((bup) ;; Archive using bup (let* ((bup-init-params (list "-d" archive-dir "init")) (bup-index-params (append (list "-d" archive-dir "index") test-paths)) (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) (conc "-" compress) ;; or (conc "--compress=" compress) | | | | | > > > > | | > > > > | | > > > > | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | (create-directory archive-dir #t)) (case archiver ((bup) ;; Archive using bup (let* ((bup-init-params (list "-d" archive-dir "init")) (bup-index-params (append (list "-d" archive-dir "index") test-paths)) (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) (conc "-" compress) ;; or (conc "--compress=" compress) "-n" (conc (common:get-testsuite-name) "-"(string-substitute "/" "-" target " ")) (conc "--strip-path=" (conc test-base target "/" )) ;; if we push to the directory do we need this? ) test-paths))) (if (not (common:file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually (debug:print-info 2 *default-log-port* "Init bup in " archive-dir) ;; (mutex-lock! bup-mutex) (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.") (exit 1)))) ;; (mutex-unlock! bup-mutex) )) (debug:print-info 2 *default-log-port* "Indexing data to be archived") ;; (mutex-lock! bup-mutex) (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.") (exit 1)))) (debug:print-info 2 *default-log-port* "Archiving data with bup") (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an archiving data with bup. Archive failed.") (exit 1)))))) ((7z tar) (for-each (lambda (test-dat) (let* ((test-id (db:test-get-id test-dat)) (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (test-full-name (db:test-make-full-name test-name item-path)) |
︙ | ︙ | |||
334 335 336 337 338 339 340 | (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync")) (print-prefix "Running: ") (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db")) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (home-host (common:get-homehost)) (archive-time (seconds->std-time-str (current-seconds))) | | | | > > > > | | > > > > | | > > > > > | | > | < | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync")) (print-prefix "Running: ") (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db")) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (home-host (common:get-homehost)) (archive-time (seconds->std-time-str (current-seconds))) (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time)) (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db")) (dbfile (conc archive-staging-db "/megatest.db"))) (create-directory archive-staging-db #t) (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix))) (if (eq? exit-code 0) (case archiver ((bup) ;; Archive using bup (let* ((bup-init-params (list "-d" archive-dir "init")) (bup-index-params (list "-d" archive-dir "index" archive-staging-db)) (bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) (conc "-" compress) ;; or (conc "--compress=" compress) "-n" (conc tsname "-megatest-db" ) (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this? dbfile))) (if (not (common:file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually (debug:print-info 2 *default-log-port* "Init bup in " archive-dir) (let-values (((pid-val exit-status exit-code)(run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.") (exit 1)))))) (debug:print-info 2 *default-log-port* "Indexing data to be archived") (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.") (exit 1)))) (debug:print-info 2 *default-log-port* "Archiving data with bup") (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.") (exit 1)) (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) (else (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver))) (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database"))))) (define (archive:restore-db archive-path ts) (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) (sleep 2) (db:multi-db-sync (db:setup #f) 'killservers ;'dejunk ;'adj-testids 'old2new ) (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") (rmt:drop-all-triggers) (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) (src-archive-linktree (rmt:get-var "src-archive-linktree"))) (if (not (equal? src-archive-linktree linktree)) (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree)) (debug:print-info 1 *default-log-port* "creating triggers after updating linktree") (rmt:create-all-triggers) )) |
︙ | ︙ | |||
410 411 412 413 414 415 416 | (define (seconds->std-time-str sec) (time->string (seconds->local-time sec) "%Y-%m-%d-%H%M%S")) | | | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | (define (seconds->std-time-str sec) (time->string (seconds->local-time sec) "%Y-%m-%d-%H%M%S")) (define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update) (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update)) (let* ((internal-path (conc testsuite-name "-" target)) (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" ))) (ts-list (archive:ls->list bup-exe archive-dir internal-path)) (ds-flag (vector-ref (seconds->local-time) 8))) (let loop ((hed (car ts-list)) (tail (cdr ts-list))) (if (and (null? tail) (equal? hed "latest")) #f |
︙ | ︙ | |||
455 456 457 458 459 460 461 | (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) (keyvals (rmt:get-key-val-pairs run-id)) (target (string-intersperse (map cadr keyvals) "/")) (toplevel/children (and (db:test-get-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) | | | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 | (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) (keyvals (rmt:get-key-val-pairs run-id)) (target (string-intersperse (map cadr keyvals) "/")) (toplevel/children (and (db:test-get-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) (test-partial-path (conc run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory (mutex-lock! rp-mutex) (prev-test-physical-path (if (common:file-exists? test-path) ;; (read-symbolic-link test-path #t) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) (archive-block-id (db:test-get-archived test-dat)) (test-last-update (db:test-get-last_update test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) (string-substitute "/" "-" target " ") test-partial-path test-last-update) #f)) (archive-internal-path (conc (common:get-testsuite-name) "-" (string-substitute "/" "-" target " ") "/" archive-timestamp-dir "/" test-partial-path)) (include-paths (args:get-arg "-include")) (exclude-pattern (args:get-arg "-exclude-rx")) (exclude-file (args:get-arg "-exclude-rx-from"))) (if (not archive-timestamp-dir) (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path) (begin ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children |
︙ | ︙ |
Modified db.scm from [fb3a18f52f] to [a5d89bbe40].
︙ | ︙ | |||
1532 1533 1534 1535 1536 1537 1538 | id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) | | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 | id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) (print "creating triggers from init") (db:create-triggers db) db)) ;; ) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== |
︙ | ︙ |
Modified megatest.scm from [0e58f17e0f] to [fd8579cb9b].
︙ | ︙ | |||
517 518 519 520 521 522 523 | "-list-disks" "-list-targets" "-show-runconfig" ;;"-list-db-targets" "-show-runconfig" "-show-config" "-show-cmdinfo" | | > > > > > > > > > > | | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 | "-list-disks" "-list-targets" "-show-runconfig" ;;"-list-db-targets" "-show-runconfig" "-show-config" "-show-cmdinfo" "-cleanup-db" )) (no-watchdog-argvals (list '("-archive" . "replicate-db"))) (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals)) (tail (cdr no-watchdog-argvals))) (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed))) (if (equal? (args:get-arg (car hed)) (cdr hed)) #f (if (null? tail) #t (loop (car tail) (cdr tail)))))) (no-watchdog-args-vals (filter (lambda (x) x) (map args:get-arg no-watchdog-args))) (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) (if start-watchdog (thread-start! *watchdog*))) ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions (define (open-logfile logpath-in) (condition-case |
︙ | ︙ | |||
1967 1968 1969 1970 1971 1972 1973 | (print path)) paths)))))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt | | | | | 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 | (print path)) paths)))))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt (if (equal? (args:get-arg "-archive") "replicate-db") (begin ;; check if source ;; check if megatest.db exist (launch:setup) (if (not (args:get-arg "-source")) (begin (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>") (exit 1))) (if (common:file-exists? (conc *toppath* "/megatest.db")) (begin (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db") |
︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 | (begin (archive:restore-db src ts) (set! *didsomething* #t)) (begin (debug:print-error 1 *default-log-port* "Path " source " not found") (exit 1)))))) ;; else do a general-run-call | | | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 | (begin (archive:restore-db src ts) (set! *didsomething* #t)) (begin (debug:print-error 1 *default-log-port* "Path " source " not found") (exit 1)))))) ;; else do a general-run-call (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) (begin ;; for the archive get we need to preserve the starting dir as part of the target path (if (and (args:get-arg "-dest") (not (equal? (substring (args:get-arg "-dest") 0 1) "/"))) (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest")))) (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath) (hash-table-set! args:arg-hash "-dest" newpath))) |
︙ | ︙ |
Modified runs.scm from [030b929939] to [ca48301598].
︙ | ︙ | |||
2200 2201 2202 2203 2204 2205 2206 | ;; delete redundant runs within a target - N is the input ;; delete redundant runs within a target IFF older than given date/time AND keep at least N ;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print))) (let* ((runs-ht (runs:get-hash-by-target target-patts runpatt)) (age (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f)) (age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400))) | | > > > > > > | > > | | | | | | | | | | | | | | | | | < < | < < | < < | > | 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 | ;; delete redundant runs within a target - N is the input ;; delete redundant runs within a target IFF older than given date/time AND keep at least N ;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print))) (let* ((runs-ht (runs:get-hash-by-target target-patts runpatt)) (age (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f)) (age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400))) (precmd (or (args:get-arg "-precmd") "")) (action-chk (member (string->symbol "remove-runs") actions))) ;; check the sequence of actions archive must comme before remove-runs (if (and action-chk (member (string->symbol "archive") action-chk)) (begin (debug:print-error 0 *default-log-port* "action remove-runs must come after archive") (exit 1))) (print "Actions: " actions " age: " age) (for-each (lambda (action) (for-each (lambda (target) (let* ((runs (hash-table-ref runs-ht target)) (sorted (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b))))) (to-remove (let* ((len (length sorted)) (trim-amt (- len num-to-keep))) (if (> trim-amt 0) (take sorted trim-amt) '())))) (hash-table-set! runs-ht target to-remove) (print target ":") (for-each (lambda (run) (let ((remove (member run to-remove (lambda (a b) (eq? (simple-run-id a) (simple-run-id b)))))) (if (and age (> (simple-run-event_time run) age-mark)) (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age")) (case action ((print) (print " " (simple-run-runname run) " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S") " " (if remove "REMOVE" ""))) ((remove-runs) (if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %" (if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0 " -kill-wait 0" ""))))) ((archive) (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))) ((kill-runs) (if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))))))) sorted))) (hash-table-keys runs-ht))) actions) runs-ht)) (define (remove-last-path-directory path-in) (let* ((dparts (string-split path-in "/")) (path-out (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/"))) ) path-out |
︙ | ︙ |
Modified sauth-common.scm from [28ffd8e69e] to [5771575e2e].
︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | (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)) | > > > > > > > > > | 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 (cdr (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 "/")) (normal-path (normalize-pathname target-path-string)) |
︙ | ︙ | |||
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 | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 | 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 [0af43ce4a9] to [d0bcfc709c].
︙ | ︙ | |||
389 390 391 392 393 394 395 396 397 398 399 400 401 402 | (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) | > > > > | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | (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 "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) |
︙ | ︙ |