| ︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
|
(configf:section-var-set! torun contour runkey
(cons spec
(or (configf:lookup torun contour runkey)
'()))))
(define (fossil:clone-or-sync url name dest-dir)
(let ((targ-file (conc dest-dir "/" name))) ;; do not force usage of .fossil extension
(handle-exceptions
(common:debug-handle-exceptions #t
exn
(print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn))
(create-directory dest-dir #t))
(handle-exceptions
(common:debug-handle-exceptions #t
exn
(print "ERROR: failed to clone or sync 1ossil " url " message: " ((condition-property-accessor 'exn 'message) exn))
(if (file-exists? targ-file)
(system (conc "fossil pull --once " url " -R " targ-file))
(system (conc "fossil clone " url " " targ-file))
))))
(define (fossil:last-change-node-and-time fossils-dir fossil-name branch)
(let* ((fossil-file (conc fossils-dir "/" fossil-name))
(timeline-port (if (file-read-access? fossil-file)
(handle-exceptions
(common:debug-handle-exceptions #t
exn
(begin
(print "ERROR: failed to get timeline from " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn))
#f)
(open-input-pipe (conc "fossil timeline -t ci -W 0 -n 0 -R " fossil-file)))
#f))
(get-line (lambda ()
(handle-exceptions
(common:debug-handle-exceptions #t
exn
(begin
(print "ERROR: failed to read from file " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn))
#f)
(read-line timeline-port))))
(date-rx (regexp "^=== (\\S+) ===$"))
(node-rx (regexp "^(\\S+) \\[(\\S+)\\].*\\(.*tags:\\s+([^\\)]+)\\)$")))
|
| ︙ | | |
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
|
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
-
+
+
|
(let* ((sched (cond
((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
((number? sched-in) sched-in)
(else (current-seconds))))
(args-data (if args-alist
args-alist
(hash-table->alist args:arg-hash)))
(alldat (apply append (list 'a action
(alldat (apply append (list 'T "cmd"
'a action
'U (current-user-name)
'D sched)
(map (lambda (x)
(let* ((param (car x))
(value (cdr x))
(pmeta (assoc param *arg-keys*))
(smeta (assoc param *switch-keys*))
|
| ︙ | | |
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
|
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
|
-
+
|
(area-path (alist-ref 'path area-dat))
(area-xlatr (alist-ref 'targtrans area-dat))
(new-target (if area-xlatr
(let ((xlatr-key (string->symbol area-xlatr)))
(if (alist-ref xlatr-key *target-mappers*)
(begin
(print "Using target mapper: " area-xlatr)
(handle-exceptions
(common:debug-handle-exceptions #t
exn
(begin
(print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
(print " function is: " (alist-ref xlatr-key *target-mappers*))
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runkey)
((alist-ref xlatr-key *target-mappers*)
|
| ︙ | | |
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
|
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
|
-
+
|
;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
(for-each
(lambda (cmd)
(print "cmd: " cmd)
(let* ((script (car cmd))
(params (cdr cmd))
(cmd (conc script " " contour " " runkey " " std-runname " " action " " params))
(res (handle-exceptions
(res (common:debug-handle-exceptions #t
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines))))
(if (and res (not (null? res)))
(let* ((parts (string-split (car res))) ;;
(rem-lines (cdr res))
|
| ︙ | | |
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
|
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
|
-
+
|
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir
(let ((logdir
(if (if (not (directory? "logs"))
(handle-exceptions
(common:debug-handle-exceptions #t
exn
#f
(create-directory "logs")
#t)
#t)
"logs"
"/tmp")))
|
| ︙ | | |