Random Bits of Open Code

Check-in [6149f777bb]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Extend constraint on runs to include area_id. Respect area name provided by dashboard config file.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:6149f777bbd68d7a830556dc65b8f932da131508
User & Date: matt 2018-05-07 02:30:19
Context
2018-05-08
03:37
Make adat-init optionally set up the megatest source area. check-in: d7beec78b6 user: matt tags: trunk
2018-05-07
02:30
Extend constraint on runs to include area_id. Respect area name provided by dashboard config file. check-in: 6149f777bb user: matt tags: trunk
2018-05-06
17:59
Minor stuff. check-in: d214c91865 user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtdb/mtdb.scm.

925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
...
943
944
945
946
947
948
949
950
951
952
953
954
955
956

957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974


975
976

977
978
979
980
981
982
983
....
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
....
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157

1158
1159
1160
1161
1162
1163
1164
1165
....
1184
1185
1186
1187
1188
1189
1190

1191
1192
1193
1194
1195
1196
1197
1198
1199
1200


1201
1202
1203
1204
1205
1206
1207
1208
1209
....
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
....
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
;;      get-run-id
;;      string-intersperse
;;      )
    (if runinf
	runinf ;; already cached
	(let* ((common-dbh (with-common-db   adat1 #f)) ;; opens the db
	       (mt-dbh     (with-megatest-db adat1 #f))
	       (main-dbh   common-dbh) ;; (with-main-db     adat2 #f))
	       (run-dat    (get-run-info-1.X adat1 run-id))            ;; NOTE: get-run-info returns a vector < row header >
	       (run-name   (get-run-name-from-id mt-dbh run-id))
	       (row        (get-rows run-dat)) ;; get-rows gets the single row returned by get-run-info-1.X
	       (header     (get-header run-dat))
	       (state      (get-value-by-header row header "state"))
	       (status     (get-value-by-header row header "status"))
	       (owner      (get-value-by-header row header "owner"))
................................................................................
	       (pass-count (get-value-by-header row header "pass_count"))
               (db-contour (get-value-by-header row header "contour"))
	       (contour    db-contour)
	       (keys       (common:config-get-fields (adat-mtconfig adat1)))
	       (keytarg    (string-intersperse keys "/")) ;; e.g. version/iteration/platform
	       ;; this is the target info from the source. BUG, this is currently WRONG
	       (target     (get-target-1.X adat1 run-id))                 ;; e.g. v1.63/a3e1/ubuntu
	       (spec-id    (get-ttype main-dbh keytarg))
	       (new-run-id (get-run-id main-dbh spec-id target run-name area-id))
	       ;; (area-id    (db:get-value-by-header row header "area_id)"))
	       )
	  (print "INFO: for area-id " area-id " have new run-id " new-run-id " for run " run-name)
	  (if new-run-id
	      (begin

		(hash-table-set! runs-ht run-id new-run-id)
		;; ensure key fields are up to date
		(refresh-run-info
		 main-dbh
		 new-run-id
		 state status owner event-time comment fail-count pass-count area-id)
		new-run-id)
	      (if (equal? state "deleted")
		  (begin 
		    (print "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
		  (handle-exceptions
		   exn
		   (begin
		     (print-call-chain)
		     (print-error ((condition-property-accessor 'exn 'message) exn))
		     (print-error "insert-run failed with spec-id: " spec-id " target: " target " run-name: " run-name " state: " state " status: " status
				  " owner: " owner " event-time: " event-time " comment: " comment " fail-count: " fail-count " pass-count: " pass-count " area-id: " area-id)
		     #f)


		   (insert-run main-dbh spec-id target run-name state status owner event-time comment fail-count pass-count  area-id)
		   (run-id->mtpg-run-id adat1 adat2 cached-info run-id area-info))))))))


;; adat1=source 1.X area, adat2 = dest 2.X area, can be same adat
;;
(define (sync-test-steps adat1 adat2 cached-info test-step-ids)
  (print "Sync Steps " test-step-ids )
  (let* ((test-ht    (hash-table-ref cached-info 'tests))
	 (step-ht    (hash-table-ref cached-info 'steps))
................................................................................
     (lambda (run-id)
       (let* ((start-time   (current-seconds))
	      (tests        (filter (lambda (t)(eq? run-id (vector-ref t 1)))(hash-table-values tinfo-cache)))
	      (pgdb-run-id  (run-id->mtpg-run-id adat1 adat2 cached-info run-id area-info))
	      (run-dbh      (with-run-db adat2 #f pgdb-run-id)))
	 (print "INFO: filtering took " (- (current-seconds) start-time) " seconds. Now syncing " (length tests) " for run " run-id)
	 (if (not pgdb-run-id)
	     (print "WARNING: Skipping run with run-id:" run-id ". This run was created after previous sync and removed before this sync.")
	     (dbi:with-transaction
	      run-dbh
	      (lambda ()
		(for-each
		 (lambda (test-info)
		   (match-let
		       (((test-id  run-id    test-name  state    status     event-time    host     cpuload
................................................................................
	  #f)
      (if (not (is-area-tagged-with-a-tag dbh (vector-ref tag-info 0)  (vector-ref area-info 0)))  
	  (insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))))))

;; attempt to automatically set up an area. call only if get area by path
;; returns naught of interest
;;
(define (set-area adat)
  (let* ((mt-cfg  (adat-mtconfig adat))
	 (toppath (adat-path    adat)))
    (with-common-db
     adat
     (lambda (dbh)

       (let loop ((area-name (or (configf:lookup mt-cfg "setup" "area-name")
				 (common:get-area-name adat)))
		  (modifier  'none))
	 (let ((success (handle-exceptions
			    exn
			    (begin
			      (print-error "WARNING: cannot create area entry with name " area-name ", " ((condition-property-accessor 'exn 'message) exn))
			      #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception
................................................................................

;; target conversion from independent fields to / sep. string
;; in the adat-path location propagate megatest.db data to main.d and 1.db ... N.db
;; 
(define (mt1-sync-to-mt2 adat1 adat2 #!key (area-tag #f)(cached-info #f))
  (close-all-dbs adat1) ;; pre-clean the situation
  (let* ((area-path   (adat-path        adat2))

	 (common-dbh  (with-common-db   adat2 #f)) ;; opens the db
	 (mt-dbh      (with-megatest-db adat1 #f))
	 (main-dbh    common-dbh) ;; (with-main-db     adat2 #f))
	 (area-info   (get-area-by-path common-dbh area-path))
	 (cached-info (or cached-info (make-hash-table)))
	 (start       (current-seconds))
	 (dbcomplete  (db-has-needed-tables mt-dbh))
	 (mtver       (if dbcomplete (get-last-run-version-number mt-dbh) -1))
	 )
    (init-cached-info cached-info)


    (print "area-info: " area-info)
    (hash-table-set! cached-info 'start start) ;; CHANGE ME TO MAX CHANGED TIME-1sec
    (if area-info
	(cond
	 ((not dbcomplete)
	  (print-error "ERROR: megatest.db in area " area-path " is corrupt or missing tables, skipping it.")
	  #f)
	 ((< mtver 1.64)
	  (print-error "ERROR: area " area-path " is too old, Megatest version " mtver ", skipping it.")
................................................................................
		  ;; (sync-test-gen-data adat1 adat2 cached-info test-data-ids))
		  ))
	    (write-sync-time common-dbh area-info start)
	    (adat-last-refresh-set! adat2 start)
	    (close-all-dbs adat1)
	    (close-all-dbs adat2)
	    ))) ;; NOTE: Need to extract the max time from the source db and use that
	(if (set-area adat2)
	    (mt1-sync-to-mt2 adat1 adat2)
	    (begin
	      (print-error "ERROR: unable to create an area record")
	      (close-all-dbs adat1)
	      (close-all-dbs adat2)
	      #f)))))

................................................................................
       owner      TEXT DEFAULT '',
       event_time INTEGER DEFAULT (strftime('%s','now')),
       comment    TEXT DEFAULT '',
       fail_count INTEGER DEFAULT 0,
       pass_count INTEGER DEFAULT 0,
       last_update INTEGER DEFAULT (strftime('%s','now')),
       area_id     INTEGER DEFAULT 0,
       CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name));"

      "CREATE TABLE IF NOT EXISTS run_stats (
       id     INTEGER PRIMARY KEY,
       run_id INTEGER,
       state  TEXT,
       status TEXT,
       count  INTEGER,







|







 







|
|


<


>



|



|










>
>
|
|
>







 







|







 







|





>
|







 







>


|






|
>
>
|
|







 







|







 







|







925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
...
943
944
945
946
947
948
949
950
951
952
953

954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
....
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
....
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
....
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
....
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
....
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
;;      get-run-id
;;      string-intersperse
;;      )
    (if runinf
	runinf ;; already cached
	(let* ((common-dbh (with-common-db   adat1 #f)) ;; opens the db
	       (mt-dbh     (with-megatest-db adat1 #f))
	       ;; (main-dbh   common-dbh) ;; (with-main-db     adat2 #f))
	       (run-dat    (get-run-info-1.X adat1 run-id))            ;; NOTE: get-run-info returns a vector < row header >
	       (run-name   (get-run-name-from-id mt-dbh run-id))
	       (row        (get-rows run-dat)) ;; get-rows gets the single row returned by get-run-info-1.X
	       (header     (get-header run-dat))
	       (state      (get-value-by-header row header "state"))
	       (status     (get-value-by-header row header "status"))
	       (owner      (get-value-by-header row header "owner"))
................................................................................
	       (pass-count (get-value-by-header row header "pass_count"))
               (db-contour (get-value-by-header row header "contour"))
	       (contour    db-contour)
	       (keys       (common:config-get-fields (adat-mtconfig adat1)))
	       (keytarg    (string-intersperse keys "/")) ;; e.g. version/iteration/platform
	       ;; this is the target info from the source. BUG, this is currently WRONG
	       (target     (get-target-1.X adat1 run-id))                 ;; e.g. v1.63/a3e1/ubuntu
	       (spec-id    (get-ttype common-dbh keytarg))
	       (new-run-id (get-run-id common-dbh spec-id target run-name area-id))
	       ;; (area-id    (db:get-value-by-header row header "area_id)"))
	       )

	  (if new-run-id
	      (begin
		(print "INFO: for area-id " area-id " have new run-id " new-run-id " for run " run-name)
		(hash-table-set! runs-ht run-id new-run-id)
		;; ensure key fields are up to date
		(refresh-run-info
		 common-dbh
		 new-run-id
		 state status owner event-time comment fail-count pass-count area-id)
		new-run-id)
	      (if (equal? state "deleted") ;; since get-run-id failed we try to insert new run record
		  (begin 
		    (print "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
		  (handle-exceptions
		   exn
		   (begin
		     (print-call-chain)
		     (print-error ((condition-property-accessor 'exn 'message) exn))
		     (print-error "insert-run failed with spec-id: " spec-id " target: " target " run-name: " run-name " state: " state " status: " status
				  " owner: " owner " event-time: " event-time " comment: " comment " fail-count: " fail-count " pass-count: " pass-count " area-id: " area-id)
		     #f)
		   (if (and (string? state)(string? status)(string? owner)) ;; pretty good heuristic that the data is good
		       (begin
			 (insert-run common-dbh spec-id target run-name state status owner event-time comment fail-count pass-count  area-id)
			 (run-id->mtpg-run-id adat1 adat2 cached-info run-id area-info))
		       #f))))))))

;; adat1=source 1.X area, adat2 = dest 2.X area, can be same adat
;;
(define (sync-test-steps adat1 adat2 cached-info test-step-ids)
  (print "Sync Steps " test-step-ids )
  (let* ((test-ht    (hash-table-ref cached-info 'tests))
	 (step-ht    (hash-table-ref cached-info 'steps))
................................................................................
     (lambda (run-id)
       (let* ((start-time   (current-seconds))
	      (tests        (filter (lambda (t)(eq? run-id (vector-ref t 1)))(hash-table-values tinfo-cache)))
	      (pgdb-run-id  (run-id->mtpg-run-id adat1 adat2 cached-info run-id area-info))
	      (run-dbh      (with-run-db adat2 #f pgdb-run-id)))
	 (print "INFO: filtering took " (- (current-seconds) start-time) " seconds. Now syncing " (length tests) " for run " run-id)
	 (if (not pgdb-run-id)
	     (print "WARNING: Skipping run with run-id:" run-id ". Run created after previous sync and removed before this sync or corrupt Megatest area.")
	     (dbi:with-transaction
	      run-dbh
	      (lambda ()
		(for-each
		 (lambda (test-info)
		   (match-let
		       (((test-id  run-id    test-name  state    status     event-time    host     cpuload
................................................................................
	  #f)
      (if (not (is-area-tagged-with-a-tag dbh (vector-ref tag-info 0)  (vector-ref area-info 0)))  
	  (insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))))))

;; attempt to automatically set up an area. call only if get area by path
;; returns naught of interest
;;
(define (set-area adat #!key (aname #f))
  (let* ((mt-cfg  (adat-mtconfig adat))
	 (toppath (adat-path    adat)))
    (with-common-db
     adat
     (lambda (dbh)
       (let loop ((area-name (or aname
				 (configf:lookup mt-cfg "setup" "area-name")
				 (common:get-area-name adat)))
		  (modifier  'none))
	 (let ((success (handle-exceptions
			    exn
			    (begin
			      (print-error "WARNING: cannot create area entry with name " area-name ", " ((condition-property-accessor 'exn 'message) exn))
			      #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception
................................................................................

;; target conversion from independent fields to / sep. string
;; in the adat-path location propagate megatest.db data to main.d and 1.db ... N.db
;; 
(define (mt1-sync-to-mt2 adat1 adat2 #!key (area-tag #f)(cached-info #f))
  (close-all-dbs adat1) ;; pre-clean the situation
  (let* ((area-path   (adat-path        adat2))
	 (area-name   (adat-name        adat2))
	 (common-dbh  (with-common-db   adat2 #f)) ;; opens the db
	 (mt-dbh      (with-megatest-db adat1 #f))
	 ;; (main-dbh    common-dbh) ;; (with-main-db     adat2 #f))
	 (area-info   (get-area-by-path common-dbh area-path))
	 (cached-info (or cached-info (make-hash-table)))
	 (start       (current-seconds))
	 (dbcomplete  (db-has-needed-tables mt-dbh))
	 (mtver       (if dbcomplete (get-last-run-version-number mt-dbh) -1))
	 )
    (init-cached-info cached-info) ;; set up the hash tables to store runs, targets, tests, steps and data
    (if area-info
	(begin
	  (print "area-info: " area-info)
	  (hash-table-set! cached-info 'start start))) ;; CHANGE ME TO MAX CHANGED TIME-1sec
    (if area-info
	(cond
	 ((not dbcomplete)
	  (print-error "ERROR: megatest.db in area " area-path " is corrupt or missing tables, skipping it.")
	  #f)
	 ((< mtver 1.64)
	  (print-error "ERROR: area " area-path " is too old, Megatest version " mtver ", skipping it.")
................................................................................
		  ;; (sync-test-gen-data adat1 adat2 cached-info test-data-ids))
		  ))
	    (write-sync-time common-dbh area-info start)
	    (adat-last-refresh-set! adat2 start)
	    (close-all-dbs adat1)
	    (close-all-dbs adat2)
	    ))) ;; NOTE: Need to extract the max time from the source db and use that
	(if (set-area adat2 aname: area-name) ;; we force to use *our* area-name and not that set by the area owner
	    (mt1-sync-to-mt2 adat1 adat2)
	    (begin
	      (print-error "ERROR: unable to create an area record")
	      (close-all-dbs adat1)
	      (close-all-dbs adat2)
	      #f)))))

................................................................................
       owner      TEXT DEFAULT '',
       event_time INTEGER DEFAULT (strftime('%s','now')),
       comment    TEXT DEFAULT '',
       fail_count INTEGER DEFAULT 0,
       pass_count INTEGER DEFAULT 0,
       last_update INTEGER DEFAULT (strftime('%s','now')),
       area_id     INTEGER DEFAULT 0,
       CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name,area_id));"

      "CREATE TABLE IF NOT EXISTS run_stats (
       id     INTEGER PRIMARY KEY,
       run_id INTEGER,
       state  TEXT,
       status TEXT,
       count  INTEGER,