37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
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
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
336
337
338
339
340
341
342
343
344
345
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
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
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
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
|
(import processmod)
(import stml2)
(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")
(define (common:low-noise-print alldat waitval . keys)
(let* ((key (string-intersperse (map conc keys) "-" ))
(lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
(currtime (current-seconds)))
(if (> (- currtime lasttime) waitval)
(begin
(hash-table-set! (alldat-denoise alldat) key currtime)
#t)
#f)))
(define (common:version-signature alldat)
(conc (alldat-megatest-version alldat)
"-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
;;======================================================================
;; T I M E A N D D A T E
;;======================================================================
;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common:hms-string->seconds tstr)
(let ((parts (string-split-fields "\\w+" tstr))
(time-secs 0)
;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
(trx (regexp "(\\d+)([smhdMyw])")))
(for-each (lambda (part)
(let ((match (string-match trx part)))
(if match
(let ((val (string->number (cadr match)))
(unt (caddr match)))
(if val
(set! time-secs (+ time-secs (* val
(case (string->symbol unt)
((s) 1)
((m) 60) ;; minutes
((h) 3600)
((d) 86400)
((w) 604800)
((M) 2628000) ;; aproximately one month
((y) 31536000)
(else #f))))))))))
parts)
time-secs))
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
(min (quotient (- secs (* hrs 3600)) 60))
(sec (- secs (* hrs 3600)(* min 60))))
(conc (if (> hrs 0)(conc hrs "hr ") "")
(if (> min 0)(conc min "m ") "")
sec "s")))
(define (seconds->time-string sec)
(time->string
(seconds->local-time sec) "%H:%M:%S"))
(define (seconds->work-week/day-time sec)
(time->string
(seconds->local-time sec) "ww%V.%u %H:%M"))
(define (seconds->work-week/day sec)
(time->string
(seconds->local-time sec) "ww%V.%u"))
(define (seconds->year-work-week/day sec)
(time->string
(seconds->local-time sec) "%yww%V.%w"))
(define (seconds->year-work-week/day-time sec)
(time->string
(seconds->local-time sec) "%Yww%V.%w %H:%M"))
(define (seconds->year-week/day-time sec)
(time->string
(seconds->local-time sec) "%Yw%V.%w %H:%M"))
(define (seconds->quarter sec)
(case (string->number
(time->string
(seconds->local-time sec)
"%m"))
((1 2 3) 1)
((4 5 6) 2)
((7 8 9) 3)
((10 11 12) 4)
(else #f)))
;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
;;
(define (common:date-time->seconds datetime)
(local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
;; given span of seconds tstart to tend
;; find start time to mark and mark delta
;;
(define (common:find-start-mark-and-mark-delta tstart tend)
(let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
(result #f)
(min 60)
(hr (* 60 60))
(day (* 24 hr))
(yr (* 365 day)) ;; year
(mo (/ yr 12))
(wk (* day 7)))
(for-each
(lambda (max-blks)
(for-each
(lambda (span) ;; 5 2 1
(if (not result)
(for-each
(lambda (timeunit timesym) ;; year month day hr min sec
(if (not result)
(let* ((time-blk (* span timeunit))
(num-blks (quotient deltat time-blk)))
(if (and (> num-blks 4)(< num-blks max-blks))
(let ((first (* (quotient tstart time-blk) time-blk)))
(set! result (list span timeunit time-blk first timesym))
)))))
(list yr mo wk day hr min 1)
'( y mo w d h m s))))
(list 8 6 5 2 1)))
'(5 10 15 20 30 40 50 500))
(if values
(apply values result)
(values 0 day 1 0 'd))))
;; given x y lim return the cron expansion
;;
(define (common:expand-cron-slash x y lim)
(let loop ((curr x)
(res `()))
(if (< curr lim)
(loop (+ curr y) (cons curr res))
(reverse res))))
;; expand a complex cron string to a list of cron strings
;;
;; x/y => x, x+y, x+2y, x+3y while x+Ny<max_for_field
;; a,b,c => a, b ,c
;;
;; NOTE: with flatten a lot of the crud below can be factored down.
;;
(define (common:cron-expand cron-str)
(if (list? cron-str)
(flatten
(fold (lambda (x res)
(if (list? x)
(let ((newres (map common:cron-expand x)))
(append x newres))
(cons x res)))
'()
cron-str)) ;; (map common:cron-expand cron-str))
(let ((cron-items (string-split cron-str))
(slash-rx (regexp "(\\d+)/(\\d+)"))
(comma-rx (regexp ".*,.*"))
(max-vals '((min . 60)
(hour . 24)
(dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
(month . 12)
(dayofweek . 7))))
(if (< (length cron-items) 5) ;; bad spec
cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it
(let loop ((hed (car cron-items))
(tal (cdr cron-items))
(type 'min)
(type-tal '(hour dayofmonth month dayofweek))
(res '()))
(regex-case
hed
(slash-rx ( _ base incr ) (let* ((basen (string->number base))
(incrn (string->number incr))
(expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
(new-list-crons (fold (lambda (x myres)
(cons (conc (if (null? res)
""
(conc (string-intersperse res " ") " "))
x " " (string-intersperse tal " "))
myres))
'() expanded-vals)))
;; (print "new-list-crons: " new-list-crons)
;; (fold (lambda (x res)
;; (if (list? x)
;; (let ((newres (map common:cron-expand x)))
;; (append x newres))
;; (cons x res)))
;; '()
(flatten (map common:cron-expand new-list-crons))))
;; (map common:cron-expand (map common:cron-expand new-list-crons))))
(else (if (null? tal)
cron-str
(loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
;; given a cron string and the last time event was processed return #t to run or #f to not run
;;
;; min hour dayofmonth month dayofweek
;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7
;;
;; #t => yes, run the job
;; #f => no, do not run the job
;;
(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
(let* ((cron-items (map string->number (string-split cron-str)))
(now-seconds (or now-seconds-in (current-seconds)))
(now-time (seconds->local-time now-seconds))
(last-done-time (seconds->local-time last-done))
(all-times (make-hash-table)))
;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
(if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
#f
(match-let ((( cmin chour cdayofmonth cmonth cdayofweek)
cron-items)
;; 0 1 2 3 4 5 6
((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
(vector->list now-time))
((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
(vector->list last-done-time)))
;; create all possible time slots
;; remove invalid slots due to (for example) day of week
;; get the start and end entries for the ref-seconds (current) time
;; if last-done > ref-seconds => this is an ERROR!
;; does the last-done time fall in the legit region?
;; yes => #f do not run again this command
;; no => #t ok to run the command
(for-each ;; month
(lambda (month)
(for-each ;; dayofmonth
(lambda (dom)
(for-each
(lambda (hr) ;; hour
(for-each
(lambda (minute) ;; minute
(let ((copy-now (apply vector (vector->list now-time))))
(vector-set! copy-now 0 0) ;; force seconds to zero
(vector-set! copy-now 1 minute)
(vector-set! copy-now 2 hr)
(vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced
(vector-set! copy-now 4 month)
(let* ((copy-now-secs (local-time->seconds copy-now))
(new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector
(if (or (not cdayofweek)
(equal? (vector-ref new-copy 6)
cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
(if (or (not cdayofmonth)
(equal? (vector-ref new-copy 3)
(+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
(hash-table-set! all-times copy-now-secs new-copy))))))
(if cmin
`(,cmin) ;; if given cmin, have to use it
(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
(if chour
`(,chour)
(list (- nhour 1) nhour (+ nhour 1))))) ;; hour
(if cdayofmonth
`(,cdayofmonth)
(list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
(if cmonth
`(,cmonth)
(list (- nmonth 1) nmonth (+ nmonth 1))))
(let ((before #f)
(is-in #f))
(for-each
(lambda (moment)
(if (and before
(<= before now-seconds)
(>= moment now-seconds))
(begin
;; (print)
;; (print "Before: " (time->string (seconds->local-time before)))
;; (print "Now: " (time->string (seconds->local-time now-seconds)))
;; (print "After: " (time->string (seconds->local-time moment)))
;; (print "Last: " (time->string (seconds->local-time last-done)))
(if (< last-done before)
(set! is-in before))
))
(set! before moment))
(sort (hash-table-keys all-times) <))
is-in)))))
(define (common:extended-cron cron-str now-seconds-in last-done)
(let ((expanded-cron (common:cron-expand cron-str)))
(if (string? expanded-cron)
(common:cron-event expanded-cron now-seconds-in last-done)
(let loop ((hed (car expanded-cron))
(tal (cdr expanded-cron)))
(if (common:cron-event hed now-seconds-in last-done)
#t
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
;;======================================================================
;; C O L O R S
;;======================================================================
(define (common:name->iup-color name)
(case (string->symbol (string-downcase name))
((red) "223 33 49")
((grey) "192 192 192")
((orange) "255 172 13")
((purple) "This is unfinished ...")))
;; (define (common:get-color-for-state-status state status)
;; (case (string->symbol state)
;; ((COMPLETED)
;; (case (string->symbol status)
;; ((PASS) "70 249 73")
;; ((WARN WAIVED) "255 172 13")
;; ((SKIP) "230 230 0")
;; (else "223 33 49")))
;; ((LAUNCHED) "101 123 142")
;; ((CHECK) "255 100 50")
;; ((REMOTEHOSTSTART) "50 130 195")
;; ((RUNNING) "9 131 232")
;; ((KILLREQ) "39 82 206")
;; ((KILLED) "234 101 17")
;; ((NOT_STARTED) "240 240 240")
;; (else "192 192 192")))
(define (common:iup-color->rgb-hex instr)
(string-intersperse
(map (lambda (x)
(number->string x 16))
(map string->number
(string-split instr)))
"/"))
;; dot-locking egg seems not to work, using this for now
;; 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))
(if (file-exists? fname)
(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
(begin
(handle-exceptions exn #f (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)
(handle-exceptions exn
#f
(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))))
(let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
(if got-lock
#t
(if (> end-time (current-seconds))
(begin
(thread-sleep! 3)
(loop (common:simple-file-lock fname expire-time: expire-time)))
#f)))))
(define (common:simple-file-release-lock fname)
(handle-exceptions
exn
#f ;; I don't really care why this failed (at least for now)
(delete-file* fname)))
;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
(define (common:lazy-modification-time fpath)
(handle-exceptions
exn
0
(file-modification-time fpath)))
;; find timestamp of newest file associated with a sqlite db file
(define (common:lazy-sqlite-db-modification-time fpath)
(let* ((glob-list (handle-exceptions
exn
`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
(glob (conc fpath "*"))))
(file-list (if (eq? 0 (length glob-list))
'("/no/such/file")
glob-list)))
(apply max
(map
common:lazy-modification-time
file-list))))
;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message
(define (common:fail-safe thunk warning-message-on-exception)
(handle-exceptions
exn
(begin
(debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception)
(debug:print-info 0 *default-log-port*
(string-substitute "\n?Error:" "nonfatal condition:"
(with-output-to-string
(lambda ()
(print-error-message exn) ))))
(debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...")
#f)
(thunk)))
(define getenv get-environment-variable)
(define (safe-setenv key val)
(if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables.
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
(if (and (string? val)
(string? key))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
(setenv key val))
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; returns list of fd count, socket count
(define (get-file-descriptor-count #!key (pid (current-process-id )))
(list
(length (glob (conc "/proc/" pid "/fd/*")))
(length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
)
)
)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
>
>
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
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
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
336
337
338
339
340
341
342
343
344
345
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
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
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
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
|
(import processmod)
(import stml2)
(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")
;; (define (common:low-noise-print alldat waitval . keys)
;; (let* ((key (string-intersperse (map conc keys) "-" ))
;; (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
;; (currtime (current-seconds)))
;; (if (> (- currtime lasttime) waitval)
;; (begin
;; (hash-table-set! (alldat-denoise alldat) key currtime)
;; #t)
;; #f)))
;;
;; (define (common:version-signature alldat)
;; (conc (alldat-megatest-version alldat)
;; "-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
;;
;; (define (common:get-fields cfgdat)
;; (let ((fields (hash-table-ref/default cfgdat "fields" '())))
;; (map car fields)))
;;
;; ;;======================================================================
;; ;; T I M E A N D D A T E
;; ;;======================================================================
;;
;; ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
;; (define (common:hms-string->seconds tstr)
;; (let ((parts (string-split-fields "\\w+" tstr))
;; (time-secs 0)
;; ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
;; (trx (regexp "(\\d+)([smhdMyw])")))
;; (for-each (lambda (part)
;; (let ((match (string-match trx part)))
;; (if match
;; (let ((val (string->number (cadr match)))
;; (unt (caddr match)))
;; (if val
;; (set! time-secs (+ time-secs (* val
;; (case (string->symbol unt)
;; ((s) 1)
;; ((m) 60) ;; minutes
;; ((h) 3600)
;; ((d) 86400)
;; ((w) 604800)
;; ((M) 2628000) ;; aproximately one month
;; ((y) 31536000)
;; (else #f))))))))))
;; parts)
;; time-secs))
;;
;; (define (seconds->hr-min-sec secs)
;; (let* ((hrs (quotient secs 3600))
;; (min (quotient (- secs (* hrs 3600)) 60))
;; (sec (- secs (* hrs 3600)(* min 60))))
;; (conc (if (> hrs 0)(conc hrs "hr ") "")
;; (if (> min 0)(conc min "m ") "")
;; sec "s")))
;;
;; (define (seconds->time-string sec)
;; (time->string
;; (seconds->local-time sec) "%H:%M:%S"))
;;
;; (define (seconds->work-week/day-time sec)
;; (time->string
;; (seconds->local-time sec) "ww%V.%u %H:%M"))
;;
;; (define (seconds->work-week/day sec)
;; (time->string
;; (seconds->local-time sec) "ww%V.%u"))
;;
;; (define (seconds->year-work-week/day sec)
;; (time->string
;; (seconds->local-time sec) "%yww%V.%w"))
;;
;; (define (seconds->year-work-week/day-time sec)
;; (time->string
;; (seconds->local-time sec) "%Yww%V.%w %H:%M"))
;;
;; (define (seconds->year-week/day-time sec)
;; (time->string
;; (seconds->local-time sec) "%Yw%V.%w %H:%M"))
;;
;; (define (seconds->quarter sec)
;; (case (string->number
;; (time->string
;; (seconds->local-time sec)
;; "%m"))
;; ((1 2 3) 1)
;; ((4 5 6) 2)
;; ((7 8 9) 3)
;; ((10 11 12) 4)
;; (else #f)))
;;
;; ;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
;; ;;
;; (define (common:date-time->seconds datetime)
;; (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
;;
;; ;; given span of seconds tstart to tend
;; ;; find start time to mark and mark delta
;; ;;
;; (define (common:find-start-mark-and-mark-delta tstart tend)
;; (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
;; (result #f)
;; (min 60)
;; (hr (* 60 60))
;; (day (* 24 hr))
;; (yr (* 365 day)) ;; year
;; (mo (/ yr 12))
;; (wk (* day 7)))
;; (for-each
;; (lambda (max-blks)
;; (for-each
;; (lambda (span) ;; 5 2 1
;; (if (not result)
;; (for-each
;; (lambda (timeunit timesym) ;; year month day hr min sec
;; (if (not result)
;; (let* ((time-blk (* span timeunit))
;; (num-blks (quotient deltat time-blk)))
;; (if (and (> num-blks 4)(< num-blks max-blks))
;; (let ((first (* (quotient tstart time-blk) time-blk)))
;; (set! result (list span timeunit time-blk first timesym))
;; )))))
;; (list yr mo wk day hr min 1)
;; '( y mo w d h m s))))
;; (list 8 6 5 2 1)))
;; '(5 10 15 20 30 40 50 500))
;; (if values
;; (apply values result)
;; (values 0 day 1 0 'd))))
;;
;; ;; given x y lim return the cron expansion
;; ;;
;; (define (common:expand-cron-slash x y lim)
;; (let loop ((curr x)
;; (res `()))
;; (if (< curr lim)
;; (loop (+ curr y) (cons curr res))
;; (reverse res))))
;;
;; ;; expand a complex cron string to a list of cron strings
;; ;;
;; ;; x/y => x, x+y, x+2y, x+3y while x+Ny<max_for_field
;; ;; a,b,c => a, b ,c
;; ;;
;; ;; NOTE: with flatten a lot of the crud below can be factored down.
;; ;;
;; (define (common:cron-expand cron-str)
;; (if (list? cron-str)
;; (flatten
;; (fold (lambda (x res)
;; (if (list? x)
;; (let ((newres (map common:cron-expand x)))
;; (append x newres))
;; (cons x res)))
;; '()
;; cron-str)) ;; (map common:cron-expand cron-str))
;; (let ((cron-items (string-split cron-str))
;; (slash-rx (regexp "(\\d+)/(\\d+)"))
;; (comma-rx (regexp ".*,.*"))
;; (max-vals '((min . 60)
;; (hour . 24)
;; (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
;; (month . 12)
;; (dayofweek . 7))))
;; (if (< (length cron-items) 5) ;; bad spec
;; cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it
;; (let loop ((hed (car cron-items))
;; (tal (cdr cron-items))
;; (type 'min)
;; (type-tal '(hour dayofmonth month dayofweek))
;; (res '()))
;; (regex-case
;; hed
;; (slash-rx ( _ base incr ) (let* ((basen (string->number base))
;; (incrn (string->number incr))
;; (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
;; (new-list-crons (fold (lambda (x myres)
;; (cons (conc (if (null? res)
;; ""
;; (conc (string-intersperse res " ") " "))
;; x " " (string-intersperse tal " "))
;; myres))
;; '() expanded-vals)))
;; ;; (print "new-list-crons: " new-list-crons)
;; ;; (fold (lambda (x res)
;; ;; (if (list? x)
;; ;; (let ((newres (map common:cron-expand x)))
;; ;; (append x newres))
;; ;; (cons x res)))
;; ;; '()
;; (flatten (map common:cron-expand new-list-crons))))
;; ;; (map common:cron-expand (map common:cron-expand new-list-crons))))
;; (else (if (null? tal)
;; cron-str
;; (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
;;
;;
;; ;; given a cron string and the last time event was processed return #t to run or #f to not run
;; ;;
;; ;; min hour dayofmonth month dayofweek
;; ;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7
;; ;;
;; ;; #t => yes, run the job
;; ;; #f => no, do not run the job
;; ;;
;; (define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
;; (let* ((cron-items (map string->number (string-split cron-str)))
;; (now-seconds (or now-seconds-in (current-seconds)))
;; (now-time (seconds->local-time now-seconds))
;; (last-done-time (seconds->local-time last-done))
;; (all-times (make-hash-table)))
;; ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
;; (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
;; #f
;; (match-let ((( cmin chour cdayofmonth cmonth cdayofweek)
;; cron-items)
;; ;; 0 1 2 3 4 5 6
;; ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
;; (vector->list now-time))
;; ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
;; (vector->list last-done-time)))
;; ;; create all possible time slots
;; ;; remove invalid slots due to (for example) day of week
;; ;; get the start and end entries for the ref-seconds (current) time
;; ;; if last-done > ref-seconds => this is an ERROR!
;; ;; does the last-done time fall in the legit region?
;; ;; yes => #f do not run again this command
;; ;; no => #t ok to run the command
;; (for-each ;; month
;; (lambda (month)
;; (for-each ;; dayofmonth
;; (lambda (dom)
;; (for-each
;; (lambda (hr) ;; hour
;; (for-each
;; (lambda (minute) ;; minute
;; (let ((copy-now (apply vector (vector->list now-time))))
;; (vector-set! copy-now 0 0) ;; force seconds to zero
;; (vector-set! copy-now 1 minute)
;; (vector-set! copy-now 2 hr)
;; (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced
;; (vector-set! copy-now 4 month)
;; (let* ((copy-now-secs (local-time->seconds copy-now))
;; (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector
;; (if (or (not cdayofweek)
;; (equal? (vector-ref new-copy 6)
;; cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
;; (if (or (not cdayofmonth)
;; (equal? (vector-ref new-copy 3)
;; (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
;; (hash-table-set! all-times copy-now-secs new-copy))))))
;; (if cmin
;; `(,cmin) ;; if given cmin, have to use it
;; (list (- nmin 1) nmin (+ nmin 1))))) ;; minute
;; (if chour
;; `(,chour)
;; (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
;; (if cdayofmonth
;; `(,cdayofmonth)
;; (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
;; (if cmonth
;; `(,cmonth)
;; (list (- nmonth 1) nmonth (+ nmonth 1))))
;; (let ((before #f)
;; (is-in #f))
;; (for-each
;; (lambda (moment)
;; (if (and before
;; (<= before now-seconds)
;; (>= moment now-seconds))
;; (begin
;; ;; (print)
;; ;; (print "Before: " (time->string (seconds->local-time before)))
;; ;; (print "Now: " (time->string (seconds->local-time now-seconds)))
;; ;; (print "After: " (time->string (seconds->local-time moment)))
;; ;; (print "Last: " (time->string (seconds->local-time last-done)))
;; (if (< last-done before)
;; (set! is-in before))
;; ))
;; (set! before moment))
;; (sort (hash-table-keys all-times) <))
;; is-in)))))
;;
;; (define (common:extended-cron cron-str now-seconds-in last-done)
;; (let ((expanded-cron (common:cron-expand cron-str)))
;; (if (string? expanded-cron)
;; (common:cron-event expanded-cron now-seconds-in last-done)
;; (let loop ((hed (car expanded-cron))
;; (tal (cdr expanded-cron)))
;; (if (common:cron-event hed now-seconds-in last-done)
;; #t
;; (if (null? tal)
;; #f
;; (loop (car tal)(cdr tal))))))))
;;
;; ;;======================================================================
;; ;; C O L O R S
;; ;;======================================================================
;;
;; (define (common:name->iup-color name)
;; (case (string->symbol (string-downcase name))
;; ((red) "223 33 49")
;; ((grey) "192 192 192")
;; ((orange) "255 172 13")
;; ((purple) "This is unfinished ...")))
;;
;; ;; (define (common:get-color-for-state-status state status)
;; ;; (case (string->symbol state)
;; ;; ((COMPLETED)
;; ;; (case (string->symbol status)
;; ;; ((PASS) "70 249 73")
;; ;; ((WARN WAIVED) "255 172 13")
;; ;; ((SKIP) "230 230 0")
;; ;; (else "223 33 49")))
;; ;; ((LAUNCHED) "101 123 142")
;; ;; ((CHECK) "255 100 50")
;; ;; ((REMOTEHOSTSTART) "50 130 195")
;; ;; ((RUNNING) "9 131 232")
;; ;; ((KILLREQ) "39 82 206")
;; ;; ((KILLED) "234 101 17")
;; ;; ((NOT_STARTED) "240 240 240")
;; ;; (else "192 192 192")))
;;
;; (define (common:iup-color->rgb-hex instr)
;; (string-intersperse
;; (map (lambda (x)
;; (number->string x 16))
;; (map string->number
;; (string-split instr)))
;; "/"))
;;
;; ;; dot-locking egg seems not to work, using this for now
;; ;; 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))
;; (if (file-exists? fname)
;; (if (> (- (current-seconds)(file-modification-time fname)) expire-time)
;; (begin
;; (handle-exceptions exn #f (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)
;; (handle-exceptions exn
;; #f
;; (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))))
;; (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
;; (if got-lock
;; #t
;; (if (> end-time (current-seconds))
;; (begin
;; (thread-sleep! 3)
;; (loop (common:simple-file-lock fname expire-time: expire-time)))
;; #f)))))
;;
;; (define (common:simple-file-release-lock fname)
;; (handle-exceptions
;; exn
;; #f ;; I don't really care why this failed (at least for now)
;; (delete-file* fname)))
;;
;; ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;; ;;
;; (define (common:lazy-modification-time fpath)
;; (handle-exceptions
;; exn
;; 0
;; (file-modification-time fpath)))
;;
;; ;; find timestamp of newest file associated with a sqlite db file
;; (define (common:lazy-sqlite-db-modification-time fpath)
;; (let* ((glob-list (handle-exceptions
;; exn
;; `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
;; (glob (conc fpath "*"))))
;; (file-list (if (eq? 0 (length glob-list))
;; '("/no/such/file")
;; glob-list)))
;; (apply max
;; (map
;; common:lazy-modification-time
;; file-list))))
;;
;;
;; ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; ;; arguments - thunk, message
;; (define (common:fail-safe thunk warning-message-on-exception)
;; (handle-exceptions
;; exn
;; (begin
;; (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception)
;; (debug:print-info 0 *default-log-port*
;; (string-substitute "\n?Error:" "nonfatal condition:"
;; (with-output-to-string
;; (lambda ()
;; (print-error-message exn) ))))
;; (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...")
;; #f)
;; (thunk)))
;;
;; (define getenv get-environment-variable)
;; (define (safe-setenv key val)
;; (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables.
;; (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
;; (if (and (string? val)
;; (string? key))
;; (handle-exceptions
;; exn
;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
;; (setenv key val))
;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
;;
;; (define home (getenv "HOME"))
;; (define user (getenv "USER"))
;;
;;
;; ;; returns list of fd count, socket count
;; (define (get-file-descriptor-count #!key (pid (current-process-id )))
;; (list
;; (length (glob (conc "/proc/" pid "/fd/*")))
;; (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
;; )
;; )
;;
)
|