︙ | | | ︙ | |
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
|
(file-age (- (current-seconds)(file-modification-time fullname))))
(if (or (and (string-match "^.*.log" file)
(> (file-size fullname) 200000))
(and (string-match "^server-.*.log" file)
(> (- (current-seconds) (file-modification-time fullname))
(* 8 60 60))))
(let ((gzfile (conc fullname ".gz")))
(if (file-exists? gzfile)
(begin
(debug:print-info 0 *default-log-port* "removing " gzfile)
(delete-file gzfile)))
(debug:print-info 0 *default-log-port* "compressing " file)
(system (conc "gzip " fullname)))
(if (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
(handle-exceptions
|
|
|
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
|
(file-age (- (current-seconds)(file-modification-time fullname))))
(if (or (and (string-match "^.*.log" file)
(> (file-size fullname) 200000))
(and (string-match "^server-.*.log" file)
(> (- (current-seconds) (file-modification-time fullname))
(* 8 60 60))))
(let ((gzfile (conc fullname ".gz")))
(if (common:file-exists? gzfile)
(begin
(debug:print-info 0 *default-log-port* "removing " gzfile)
(delete-file gzfile)))
(debug:print-info 0 *default-log-port* "compressing " file)
(system (conc "gzip " fullname)))
(if (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
(handle-exceptions
|
︙ | | | ︙ | |
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
(dbstruct (db:setup #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
((and (file-exists? mtconf) (file-exists? dbfile) (not read-only)
(eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
(debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "Failed to switch versions.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
(exit 1))
(common:cleanup-db dbstruct)))
((not (file-exists? mtconf))
(debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.")
(exit 1))
((not (file-exists? dbfile))
(debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.")
(exit 1))
((not (eq? (current-user-id)(file-owner mtconf)))
(debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.")
(exit 1))
(read-only
(debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.")
|
|
|
|
|
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
(dbstruct (db:setup #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)
(eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
(debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "Failed to switch versions.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
(exit 1))
(common:cleanup-db dbstruct)))
((not (common:file-exists? mtconf))
(debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.")
(exit 1))
((not (common:file-exists? dbfile))
(debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.")
(exit 1))
((not (eq? (current-user-id)(file-owner mtconf)))
(debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.")
(exit 1))
(read-only
(debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.")
|
︙ | | | ︙ | |
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
|
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(handle-exceptions
exn
#f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail.
(if (file-exists? fname)
(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
(begin
(delete-file* fname)
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
(thread-sleep! 0.25)
(if (file-exists? fname)
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line))))
#f)))))
(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
(let ((end-time (+ expire-time (current-seconds))))
|
|
|
|
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
|
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(handle-exceptions
exn
#f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail.
(if (common:file-exists? fname)
(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
(begin
(delete-file* fname)
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
(thread-sleep! 0.25)
(if (common:file-exists? fname)
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line))))
#f)))))
(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
(let ((end-time (+ expire-time (current-seconds))))
|
︙ | | | ︙ | |
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
|
(define (common:which cmds)
(if (null? cmds)
#f
(let loop ((hed (car cmds))
(tal (cdr cmds)))
(let ((res (with-input-from-pipe (conc "which " hed) read-line)))
(if (and (string? res)
(file-exists? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(define (common:get-install-area)
(let ((exe-path (car (argv))))
(if (file-exists? exe-path)
(handle-exceptions
exn
#f
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
|
|
|
|
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
|
(define (common:which cmds)
(if (null? cmds)
#f
(let loop ((hed (car cmds))
(tal (cdr cmds)))
(let ((res (with-input-from-pipe (conc "which " hed) read-line)))
(if (and (string? res)
(common:file-exists? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(define (common:get-install-area)
(let ((exe-path (car (argv))))
(if (common:file-exists? exe-path)
(handle-exceptions
exn
#f
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
|
︙ | | | ︙ | |
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
|
(thread-sleep! delay-time)
(common:get-homehost trynum: (- trynum 1)))
(begin
(mutex-unlock! *homehost-mutex*)
(debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn))
(exit 1)))
(let ((hhf (conc *toppath* "/.homehost")))
(if (file-exists? hhf)
(with-input-from-file hhf read-line)
(if (file-write-access? *toppath*)
(begin
(with-output-to-file hhf
(lambda ()
(print bestadrs)))
(begin
|
|
|
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
|
(thread-sleep! delay-time)
(common:get-homehost trynum: (- trynum 1)))
(begin
(mutex-unlock! *homehost-mutex*)
(debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn))
(exit 1)))
(let ((hhf (conc *toppath* "/.homehost")))
(if (common:file-exists? hhf)
(with-input-from-file hhf read-line)
(if (file-write-access? *toppath*)
(begin
(with-output-to-file hhf
(lambda ()
(print bestadrs)))
(begin
|
︙ | | | ︙ | |
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
|
;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
;;
(define (common:load-views-config)
(let* ((view-cfgdat (make-hash-table))
(home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config"))
(mthome-cfgfile (conc *toppath* "/.mtviews.config")))
(if (file-exists? mthome-cfgfile)
(read-config mthome-cfgfile view-cfgdat #t))
;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
(if (file-exists? home-cfgfile)
(read-config home-cfgfile view-cfgdat #t))
view-cfgdat))
;;======================================================================
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================
|
|
|
|
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
|
;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
;;
(define (common:load-views-config)
(let* ((view-cfgdat (make-hash-table))
(home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config"))
(mthome-cfgfile (conc *toppath* "/.mtviews.config")))
(if (common:file-exists? mthome-cfgfile)
(read-config mthome-cfgfile view-cfgdat #t))
;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
(if (common:file-exists? home-cfgfile)
(read-config home-cfgfile view-cfgdat #t))
view-cfgdat))
;;======================================================================
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================
|
︙ | | | ︙ | |