| ︙ | | | ︙ | |
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
|
(let* ((run-id (db:get-value-by-header run header "id"))
(run-state (db:get-value-by-header run header "state"))
(run-name (db:get-value-by-header run header "runname"))
(tests (if (not (equal? run-state "locked"))
(proc-get-tests run-id)
'()))
(lasttpath "/does/not/exist/I/hope")
(worker-thread #f))
(debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((kill-runs)
(tasks:kill-runner target run-name "%")
|
>
|
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
|
(let* ((run-id (db:get-value-by-header run header "id"))
(run-state (db:get-value-by-header run header "state"))
(run-name (db:get-value-by-header run header "runname"))
(tests (if (not (equal? run-state "locked"))
(proc-get-tests run-id)
'()))
(lasttpath "/does/not/exist/I/hope")
(lastrealpath "/does/not/exist/I/hope")
(worker-thread #f))
(debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((kill-runs)
(tasks:kill-runner target run-name "%")
|
| ︙ | | | ︙ | |
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
|
(mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
(thread-sleep! 1)))
;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
(if (null? tal)
(loop new-test-dat tal)
(loop (car tal)(append tal (list new-test-dat)))))
(begin
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
((kill-runs)
;; RUNNING -> KILLREQ
;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
(cond
|
>
>
>
>
>
>
|
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
|
(mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
(thread-sleep! 1)))
;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
(if (null? tal)
(loop new-test-dat tal)
(loop (car tal)(append tal (list new-test-dat)))))
(begin
(set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
(if (file-exists? lasttpath)
(set! lastrealpath (resolve-pathname lasttpath))
(set! lastrealpath lasttpath)
)
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
((kill-runs)
;; RUNNING -> KILLREQ
;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
(cond
|
| ︙ | | | ︙ | |
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
|
(if worker-thread (thread-join! worker-thread)))
(common:join-backgrounded-threads))))
;; remove the run if zero tests remain
(if (eq? action 'remove-runs)
(let* ((run-id (db:get-value-by-header run header "id")) ;; NB// masks run-id from above?
(remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t)))
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
(debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
(if (not keep-records)
(begin
(rmt:delete-run run-id)
(rmt:delete-old-deleted-test-records)))
;; (rmt:set-var "DELETED_TESTS" (current-seconds))
;; need to figure out the path to the run dir and remove it if empty
;; (if (null? (glob (conc runpath "/*")))
;; (begin
;; (debug:print 1 *default-log-port* "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
)
#t)
|
>
>
|
>
|
>
|
|
|
|
>
|
|
>
>
>
|
<
<
<
|
>
|
|
|
>
|
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
|
(if worker-thread (thread-join! worker-thread)))
(common:join-backgrounded-threads))))
;; remove the run if zero tests remain
(if (eq? action 'remove-runs)
(let* ((run-id (db:get-value-by-header run header "id")) ;; NB// masks run-id from above?
(remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t)))
(if (null? remtests) ;; no more tests remaining
;; Remove the last dir from the path.
;; And same for the link-resolved path
(let* ((dparts (string-split lasttpath "/"))
(linkspath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))
(real-dparts (string-split lastrealpath "/"))
(realpath (conc "/" (string-intersperse (take real-dparts (- (length real-dparts) 1)) "/")))
)
(debug:print 1 *default-log-port* "Removing run: " linkspath)
(if (not keep-records)
(begin
(debug:print 1 *default-log-port* "Removing DB records for the run.")
(rmt:delete-run run-id)
(rmt:delete-old-deleted-test-records))
)
(debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
(runs:recursive-delete-with-error-msg linkspath)
(debug:print 1 *default-log-port* "Recursively removing real dir " realpath)
(runs:recursive-delete-with-error-msg realpath)
)))))
))
runs)
;; (sqlite3:finalize! (db:delay-if-busy tdbdat))
)
#t
)
(define (runs:remove-test-directory test mode) ;; remove-data-only)
(let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree
(real-dir (if (common:file-exists? run-dir)
;; (resolve-pathname run-dir)
(common:nice-path run-dir)
#f))
|
| ︙ | | | ︙ | |
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
|
((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
(debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
(if (and real-dir
(> (string-length real-dir) 5)
(common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
(begin ;; let* ((realpath (resolve-pathname run-dir)))
(debug:print-info 1 *default-log-port* "Recursively removing " real-dir)
(if (common:file-exists? real-dir)
(runs:safe-delete-test-dir real-dir)
(debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable")))
(if real-dir
(debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
(debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
(if (symbolic-link? run-dir)
(begin
(debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
(handle-exceptions
|
|
|
|
|
|
|
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
|
((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
(debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
(if (and real-dir
(> (string-length real-dir) 5)
(common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
(let* ((realpath (resolve-pathname run-dir)))
(debug:print-info 1 *default-log-port* "Recursively removing " realpath)
(if (common:file-exists? realpath)
(runs:safe-delete-test-dir realpath)
(debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
(if real-dir
(debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
(debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
(if (symbolic-link? run-dir)
(begin
(debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
(handle-exceptions
|
| ︙ | | | ︙ | |