Overview
Comment: | set state/status almost working with mtutil. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.65 |
Files: | files | file ages | folders |
SHA1: |
7d703fee73ee850af7325ac7e4eebb65 |
User & Date: | matt on 2017-06-18 23:35:25 |
Other Links: | branch diff | manifest | tags |
Context
2017-06-18
| ||
23:43 | Added missing parts to get -set-state-status working check-in: 7e269b22b6 user: matt tags: v1.65 | |
23:35 | set state/status almost working with mtutil. check-in: 7d703fee73 user: matt tags: v1.65 | |
23:19 | Migrated changes for better suite of error messages in pkt handling into common.scm (changes were accidentally made in v1.64). check-in: 6b673d1216 user: matt tags: v1.65 | |
Changes
Modified http-transport.scm from [2868f6cbd2] to [3d5c1d714d].
︙ | ︙ | |||
429 430 431 432 433 434 435 | (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds)) (flush-output *default-log-port*))) (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)) | | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 | (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds)) (flush-output *default-log-port*))) (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)) (adjusted-timeout (if (> hrs-since-start 1) ;; never used! (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour server-timeout))) (if (common:low-noise-print 120 "server timeout") (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout)) (cond ((and *server-run* (> (+ last-access server-timeout) |
︙ | ︙ |
Modified mtut.scm from [104c5d0ca1] to [0d3e416b5b].
︙ | ︙ | |||
165 166 167 168 169 170 171 172 173 174 175 176 177 178 | '( ("-area" . G) ;; maps to group ("-contour" . c) ("-append-config" . d) ("-state" . e) ("-item-patt" . i) ("-sync-to" . k) ("-run-name" . n) ("-mode-patt" . o) ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" ("-status" . s) ("-target" . t) ("-tag-expr" . x) ;; misc | > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | '( ("-area" . G) ;; maps to group ("-contour" . c) ("-append-config" . d) ("-state" . e) ("-item-patt" . i) ("-sync-to" . k) ("-new" . l) ;; l (see below) is new-ss ("-run-name" . n) ("-mode-patt" . o) ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" ("-status" . s) ("-target" . t) ("-tag-expr" . x) ;; misc |
︙ | ︙ | |||
222 223 224 225 226 227 228 229 230 231 232 233 234 235 | (D . timestamp ) (T . cardtype ) (U . user ) ;; username (Z . shar1sum ) ;; Extras (a . runkey ) ;; needed for matching up pkts with target derived from runkey )) ;; inlst is an alternative input ;; (define (lookup-param-by-key key #!key (inlst #f)) (fold (lambda (a res) (if (eq? (cdr a) key) | > | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | (D . timestamp ) (T . cardtype ) (U . user ) ;; username (Z . shar1sum ) ;; Extras (a . runkey ) ;; needed for matching up pkts with target derived from runkey ;; (l . new-ss ) ;; new state/status )) ;; inlst is an alternative input ;; (define (lookup-param-by-key key #!key (inlst #f)) (fold (lambda (a res) (if (eq? (cdr a) key) |
︙ | ︙ | |||
249 250 251 252 253 254 255 | ;; (define (param-translate param) (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") (-mode-patt . "--modepatt") (-run-name . "-runname") (-test-patt . "-testpatt") | | > | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 | ;; (define (param-translate param) (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") (-mode-patt . "--modepatt") (-run-name . "-runname") (-test-patt . "-testpatt") (-msg . "-m") (-new . "-set-state-status"))) param)) (define (val->alist val) (let ((val-list (string-split-fields ";\\s*" val #:infix))) (if val-list (map (lambda (x) (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) |
︙ | ︙ | |||
392 393 394 395 396 397 398 | ;; collect, translate, collate and assemble a pkt from the command-line ;; ;; sched => force the run start time to be recorded as sched Unix ;; epoch. This aligns times properly for triggers in some cases. ;; ;; extra-dat format is ( 'x xval 'y yval .... ) ;; | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 | ;; collect, translate, collate and assemble a pkt from the command-line ;; ;; sched => force the run start time to be recorded as sched Unix ;; epoch. This aligns times properly for triggers in some cases. ;; ;; extra-dat format is ( 'x xval 'y yval .... ) ;; (define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f)) (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 (if (hash-table? args-alist) ;; seriously? (hash-table->alist args-alist) |
︙ | ︙ | |||
836 837 838 839 840 841 842 | (areas (val-alist->areas cval-alist)) (selector (alist-ref 'selector cval-alist)) (mode-tag (and selector (string-split-fields "/" selector #:infix))) (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) (print "contour: " contour " areas=" areas " cval=" cval) (for-each | | | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 | (areas (val-alist->areas cval-alist)) (selector (alist-ref 'selector cval-alist)) (mode-tag (and selector (string-split-fields "/" selector #:infix))) (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) (print "contour: " contour " areas=" areas " cval=" cval) (for-each (lambda (runkeydatset) ;; (print "runkeydatset: ")(pp runkeydatset) (let ((runkey (car runkeydatset)) (runkeydats (cadr runkeydatset))) (for-each (lambda (runkeydat) (for-each (lambda (area) |
︙ | ︙ | |||
978 979 980 981 982 983 984 | (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) (areadat (if areasec (val->alist areasec) #f)) (area-path (if areadat (alist-ref 'path areadat) #f)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) | | > | | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 | (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) (areadat (if areasec (val->alist areasec) #f)) (area-path (if areadat (alist-ref 'path areadat) #f)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) (adjargs (hash-table-copy args:arg-hash)) (new-ss (args:get-arg "-new"))) ;; check a few things (if (and area (not area-path)) (begin (print "ERROR: the specified area was not found in the [areas] table. Area name=" area) (exit 1))) ;; (for-each ;; (lambda (key) ;; (if (not (member key *legal-params*)) ;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil ;; (hash-table-keys adjargs)) (let-values (((uuid pkt) (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss))) (write-pkt pktsdir uuid pkt)))) ((dispatch import rungen process) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (toppath (configf:lookup mtconf "scratchdat" "toppath"))) (case (string->symbol *action*) ((process) (begin |
︙ | ︙ |