Megatest

Check-in [b8180b058c]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Switched to using exceptions to pass back client/server communicatioin issues
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | try-nanomsg
Files: files | file ages | folders
SHA1: b8180b058c4d14cf06d16357981afc2c20a91e00
User & Date: matt on 2014-11-28 16:01:34
Other Links: branch diff | manifest | tags
Context
2014-11-28
19:41
Increased timeout on server calls to 25 seconds. check-in: 25be6b4eef user: matt tags: try-nanomsg
16:01
Switched to using exceptions to pass back client/server communicatioin issues check-in: b8180b058c user: matt tags: try-nanomsg
2014-11-26
23:49
Corrected part of broken sync check-in: befb5004e8 user: matt tags: try-nanomsg
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified api.scm from [8d21d552d9] to [9dabd7e423].

︙
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

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








-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
+
+

-
-
-
-
+
+
+
+

-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+

-
-
-
-
+
+
+
+
-
-
-
-








    testmeta-get-record))

;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )
;;
(define (api:execute-requests dbstruct cmd params)
  (let ((res
	 (case (if (symbol? cmd) 
		   cmd
		   (string->symbol cmd))
	   ;; SERVERS
	   ((start-server)                 (apply server:kind-run params))
	   ((kill-server)                  (set! *server-run* #f))

	   ;; KEYS
	   ((get-key-val-pairs)            (apply db:get-key-val-pairs dbstruct params))
	   ((get-keys)                     (db:get-keys dbstruct))
(define (api:execute-requests dbstruct dat)
  (handle-exceptions
   exn
   (let ((call-chain (get-call-chain)))
     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
   (if (not (vector? dat))                    ;; it is an error to not receive a vector
       (vector #f #f "remote must be called with a vector")       
       (vector                                   ;; return a vector + the returned data structure
	#t 
	(let ((cmd    (vector-ref dat 0))
	      (params (vector-ref dat 1)))
	  (case (if (symbol? cmd)
		    cmd
		    (string->symbol cmd))
	    ;; SERVERS
	    ((start-server)                 (apply server:kind-run params))
	    ((kill-server)                  (set! *server-run* #f))
	    
	    ;; KEYS
	    ((get-key-val-pairs)            (apply db:get-key-val-pairs dbstruct params))
	    ((get-keys)                     (db:get-keys dbstruct))

	   ;; TESTS
	   ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
	   ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
	   ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
	   ((test-set-state-status-by-id)     (apply db:test-set-state-status-by-id dbstruct params))
	   ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
	   ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
	   ((delete-test-records)             (apply db:delete-test-records dbstruct params))
	   ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
	   ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
	   ((test-set-status-state)           (apply db:test-set-status-state dbstruct params))
	   ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
	   ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
	   ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
	   ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
	   ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
	   ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
	   ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
	   ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
	   ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
	   ((roll-up-pass-fail-counts)        (apply db:roll-up-pass-fail-counts dbstruct params))
	   ((update-fail-pass-counts)         (apply db:general-call dbstruct 'update-pass-fail-counts params))
	   ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
	    ;; TESTS
	    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
	    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
	    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
	    ((test-set-state-status-by-id)     (apply db:test-set-state-status-by-id dbstruct params))
	    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
	    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
	    ((delete-test-records)             (apply db:delete-test-records dbstruct params))
	    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
	    ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
	    ((test-set-status-state)           (apply db:test-set-status-state dbstruct params))
	    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
	    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
	    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
	    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
	    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
	    ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
	    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
	    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
	    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
	    ((roll-up-pass-fail-counts)        (apply db:roll-up-pass-fail-counts dbstruct params))
	    ((update-fail-pass-counts)         (apply db:general-call dbstruct 'update-pass-fail-counts params))
	    ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))

	   ;; RUNS
	   ((get-run-info)                 (apply db:get-run-info dbstruct params))
	   ((get-run-status)               (apply db:get-run-status dbstruct params))
	   ((set-run-status)               (apply db:set-run-status dbstruct params))
	   ((register-run)                 (apply db:register-run dbstruct params))
	   ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
	   ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
	   ((get-test-id)                  (apply db:get-test-id dbstruct params))
	   ((get-tests-for-runs-mindata)   (apply db:get-tests-for-runs-mindata dbstruct params))
	   ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
	   ((delete-run)                   (apply db:delete-run dbstruct params))
	   ((get-runs)                     (apply db:get-runs dbstruct params))
	   ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
	   ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
	   ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
	   ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
	   ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
	   ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
	   ((find-and-mark-incomplete)     (apply db:find-and-mark-incomplete dbstruct params))
	    ;; RUNS
	    ((get-run-info)                 (apply db:get-run-info dbstruct params))
	    ((get-run-status)               (apply db:get-run-status dbstruct params))
	    ((set-run-status)               (apply db:set-run-status dbstruct params))
	    ((register-run)                 (apply db:register-run dbstruct params))
	    ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
	    ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
	    ((get-test-id)                  (apply db:get-test-id dbstruct params))
	    ((get-tests-for-runs-mindata)   (apply db:get-tests-for-runs-mindata dbstruct params))
	    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
	    ((delete-run)                   (apply db:delete-run dbstruct params))
	    ((get-runs)                     (apply db:get-runs dbstruct params))
	    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
	    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
	    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
	    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
	    ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
	    ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
	    ((find-and-mark-incomplete)     (apply db:find-and-mark-incomplete dbstruct params))

	   ;; STEPS
	   ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
	    ;; STEPS
	    ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))

	   ;; TEST DATA
	   ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
	   ((csv->test-data)               (apply db:csv->test-data dbstruct params))
	   ((get-steps-data)               (apply db:get-steps-data dbstruct params))
	    ;; TEST DATA
	    ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
	    ((csv->test-data)               (apply db:csv->test-data dbstruct params))
	    ((get-steps-data)               (apply db:get-steps-data dbstruct params))

	   ;; MISC
	   ((login)                        (apply db:login dbstruct params))
	   ((general-call)                 (let ((stmtname   (car params))
						 (run-id     (cadr params))
						 (realparams (cddr params)))
					     (db:with-db dbstruct run-id #t ;; these are all for modifying the db
							 (lambda (db)
							   (db:general-call db stmtname realparams)))))
	   ((sync-inmem->db)               (let ((run-id (car params)))
					     (db:sync-touched dbstruct run-id force-sync: #t)))
	   ((sdb-qry)                      (apply sdb:qry params))
	   ((ping)                         (current-process-id))
	    ;; MISC
	    ((login)                        (apply db:login dbstruct params))
	    ((general-call)                 (let ((stmtname   (car params))
						  (run-id     (cadr params))
						  (realparams (cddr params)))
					      (db:with-db dbstruct run-id #t ;; these are all for modifying the db
							  (lambda (db)
							    (db:general-call db stmtname realparams)))))
	    ((sync-inmem->db)               (let ((run-id (car params)))
					      (db:sync-touched dbstruct run-id force-sync: #t)))
	    ((sdb-qry)                      (apply sdb:qry params))
	    ((ping)                         (current-process-id))

	   ;; TESTMETA
	   ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))
	   ((testmeta-add-record)       (apply db:testmeta-add-record dbstruct params))
	   ((testmeta-update-field)     (apply db:testmeta-update-field dbstruct params)))))
	    ;; TESTMETA
	    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))
	    ((testmeta-add-record)       (apply db:testmeta-add-record dbstruct params))
	    ((testmeta-update-field)     (apply db:testmeta-update-field dbstruct params))))))))
    (vector #t res)))
	 ;; NO ELSE - let it return undef
	 ;;(else
	 ;; (list "ERROR" 0))))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
︙

Modified client.scm from [0a4fff7154] to [eb2cd66f13].

︙
71
72
73
74
75
76
77
78

79
80
81
82
83
84
85

71
72
73
74
75
76
77

78
79
80
81
82
83
84
85








-
+








		     (start-res (case *transport-type*
				  ((http)(http-transport:client-connect iface port))
				  ((nmsg)(nmsg-transport:client-connect hostname port))))
		     (ping-res  (case *transport-type* 
				  ((http)(rmt:login-no-auto-client-setup start-res run-id))
				  ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id)))
 					   (if logininfo
 					       (vector-ref (vector-ref logininfo 1) 1)
 					       (car (vector-ref logininfo 1))
 					       #f))))))
		(if (and start-res
			 ping-res)
		    (begin
		      (hash-table-set! *runremote* run-id start-res)
		      (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res))
		      start-res)
︙

Modified common.scm from [0598bb95e7] to [be492a0d26].

︙
222
223
224
225
226
227
228

229
230
231
232
233
234
235

222
223
224
225
226
227
228
229
230
231
232
233
234
235
236








+








  (debug:print-info 2 "starting exit process, finalizing databases.")
  (rmt:print-db-stats)
  (let ((run-ids (hash-table-keys *db-local-sync*)))
    (if (and (not (null? run-ids))
	     (configf:lookup *configdat* "setup" "megatest-db"))
	(db:multi-db-sync run-ids 'new2old)))
  (if *dbstruct-db* (db:close-all *dbstruct-db*))
  (if *inmemdb*     (db:close-all *inmemdb*))
  (if (and *megatest-db*
	   (sqlite3:database? *megatest-db*))
      (begin
	(sqlite3:interrupt! *megatest-db*)
	(sqlite3:finalize! *megatest-db* #t)
	(set! *megatest-db* #f)))
  (if *task-db*     (let ((db (cdr *task-db*)))
︙

Modified docs/manual/megatest_manual.html from [191f1255c5] to [00b842ca8d].

︙
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030

1010
1011
1012
1013
1014
1015
1016







1017
1018
1019
1020
1021
1022
1023








-
-
-
-
-
-
-








sudo netstat -lptu
sudo netstat -tulpn</code></pre>
</div></div>
</div>
</div>
</div>
<h1 id="_reference">Reference</h1>
<div class="sect1">
<h2 id="_the_first_chapter_of_the_second_part_2">The First Chapter of the Second Part</h2>
<div class="sectionbody">
<div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain
sub-sections.</p></div>
</div>
</div>
<div class="sect1">
<h2 id="_the_testconfig_file">The testconfig File</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_setup_section">Setup section</h3>
<div class="sect3">
<h4 id="_header">Header</h4>
︙
1182
1183
1184
1185
1186
1187
1188

































1189
1190
1191
1192
1193
1194
1195

1175
1176
1177
1178
1179
1180
1181
1182
1183
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
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








<td class="icon">
<div class="title">Note</div>
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
<div class="paragraph"><p>These routines can be called from the megatest repl.</p></div>
<div class="tableblock">
<table rules="all"
width="70%"
frame="hsides"
cellspacing="0" cellpadding="4">
<caption class="title">Table 2. API Calls</caption>
<col width="20%" />
<col width="40%" />
<col width="40%" />
<thead>
<tr>
<th align="center" valign="top">API Call             </th>
<th align="left" valign="top">Parameters </th>
<th align="left" valign="top"> Returns</th>
</tr>
</thead>
<tfoot>
<tr>
<td align="center" valign="top"><p class="table">rmt:start-server</p></td>
<td align="left" valign="top"><p class="table"><code>run-id</code></p></td>
<td align="left" valign="top"><p class="table"><code>#( success/fail   n/a )</code></p></td>
</tr>
</tfoot>
<tbody>
</tbody>
</table>
</div>
<div class="sect2">
<h3 id="_megatest_internals">Megatest Internals</h3>
<div class="imageblock graphviz">
<div class="content">
<img src="server.png" alt="server.png" />
</div>
</div>
︙
1273
1274
1275
1276
1277
1278
1279
1280

1281
1282
1283
1284

1299
1300
1301
1302
1303
1304
1305

1306
1307
1308
1309
1310








-
+





</div>
</div>
</div>
<div id="footnotes"><hr /></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br />
Last updated 2014-10-08 23:02:21 MST
Last updated 2014-11-25 21:11:28 MST
</div>
</div>
</body>
</html>

Modified docs/manual/reference.txt from [eff8aa5426] to [ddb57ef21a]. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

1
2
3
4






5
6
7
8
9
10
11





-
-
-
-
-
-









Reference
=========

The First Chapter of the Second Part
------------------------------------

Chapters grouped into book parts are at level 1 and can contain
sub-sections.

The testconfig File
-------------------

Setup section
~~~~~~~~~~~~~

Header
︙
176
177
178
179
180
181
182























183
184
185

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








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





-----------------
[triggers]
COMPLETED/ xterm -e bash -s -- 
-----------------

NOTE: There is a trailing space after the --

Programming API
---------------

These routines can be called from the megatest repl. 

.API Server Management Calls
[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header,footer"]
|======================
|API Call                  | Purpose comments   | Returns                 | Comments
|(rmt:start-server run-id) |                    | #( success/fail   n/a ) | 
|(rmt:kill-server  run-id) |                    | #( success/fail   n/a ) | Works only if the server is still reachable
|(rmt:login        run-id) | Verify the the version, testsuite area etc. are correct. | #( #t "successful login" ) |
|======================

.API Keys Related Calls
[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header,footer"]
|======================
|API Call                        | Purpose comments   | Returns                 | Comments
|(rmt:get-keys run-id)           |                    | ( key1 key2 ... )       | 
| (rmt:get-key-val-pairs run-id) |                    | #t=success/#f=fail      | Works only if the server is still reachable
|======================


:numbered!:

Modified nmsg-transport.scm from [fe6d9123a8] to [8315cf8dc1].

︙
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

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








+






-
+



















-
-
-
-
-
-
-
-
-
+
-
-
-
+
+
-
-
-
+
+
+
-








+








  (debug:print 2 "Attempting to start the server ...")
  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
	 (server-thread   (make-thread (lambda ()
					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
				       "server thread"))
	 (tdbdat          (tasks:open-db)))
    (thread-start! server-thread)
    (thread-sleep! 0.1)
    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
	  (set! *inmemdb*  dbstruct)
	  ;; (set! *inmemdb*  dbstruct)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
	  (thread-start! (make-thread
			  (lambda ()(nmsg-transport:keep-running server-id run-id))
			  "keep running"))
	  (thread-join! server-thread))
	(if (> retrynum 0)
	    (begin
	      (debug:print 0 "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
	      (portlogger:open-run-close portlogger:set-failed start-port)
	      (nmsg-transport:run dbstruct hostn run-id server-id))
	    (begin
	      (debug:print 0 "ERROR: could not find an open port to start server on. Giving up")
	      (exit 1))))))

(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
  (let ((repsoc (nn-socket 'rep)))
    (nn-bind repsoc (conc "tcp://*:" portnum))
    (let loop ((msg-in (nn-recv repsoc)))
      (cond
       ((equal? msg-in "quit")
	(nn-send repsoc "Ok, quitting"))
       ((and (>= (string-length msg-in) 4)
	     (equal? (substring msg-in 0 4) "ping"))
	(nn-send repsoc (conc (current-process-id)))
	(loop (nn-recv repsoc)))
       (else
	(let* ((dat    (db:string->obj msg-in transport: 'nmsg))
      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
	       (cmd    (vector-ref dat 0))
	       (params (vector-ref dat 1))
	       (result (api:execute-requests dbstruct cmd params))
	(debug:print 0 "server, received: " dat)
	(let ((result (api:execute-requests dbstruct dat)))
	       (newdat (db:obj->string result transport: 'nmsg)))
	  (nn-send repsoc newdat)
	  (loop (nn-recv repsoc))))))))
	  (debug:print 0 "server, sending: " result)
	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
	(loop (nn-recv repsoc))))))


;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
  (let* ((tdbdat   (tasks:open-db))
	 (dbstruct (db:setup run-id))
	 (hostn    (or (args:get-arg "-server") "-")))
    (set! *run-id*   run-id)
    (set! *inmemdb* dbstruct)
    ;; with nbfake daemonize isn't really needed
    ;;
    ;; (if (args:get-arg "-daemonize")
    ;;     (begin
    ;;       (daemon:ize)
    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
    ;;           (begin
︙
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

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








+
-
-
-
+
+
+
+

-
+

















+
+
-
+



+





-
+













+







+
-
+
+
+
+
+
+
+
+
+
+
+
+
+








			  (equal? hostn "-")) ;; use localhost
		      (get-host-name)
		      hostn))
	 (req     (or socket
		      (let ((soc (nn-socket 'req)))
			(nn-connect soc (conc "tcp://" host ":" port))
			soc)))
	 (success #t)
	 (dat     (db:obj->string (vector "ping" our-key) transport: 'nmsg))
	 (result  (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout))
	 (success (vector-ref result 0))
	 (dat     (vector "ping" our-key))
	 (result  (condition-case 
		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
		   ((timeout)(set! success #f) #f)))
	 (key     (if success 
		      (vector-ref (db:string->obj (vector-ref result 1) transport: 'nmsg) 1)
		      (vector-ref result 1)
		      #f)))
    (debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
    (if (and success
	     (or (not expected-key) ;; just getting a reply is good enough then
		 (equal? key expected-key)))
	(if return-socket
	    req
	    (begin
	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
	      #t))
	(begin
	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
	  #f))))

;; send data to server, wait max of timeout seconds for a response.
;; return #( success/fail result )
;;
;; for effiency it is easier to do the obj->string and string->obj here.
;;
(define (nmsg-transport:client-api-send-receive-raw socreq dat #!key (timeout 5))
(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 5))
  (let* ((success     #f)
	 (result      #f)
	 (keepwaiting #t)
	 (dat         (db:obj->string indat transport: 'nmsg))
	 (send-recv   (make-thread
		       (lambda ()
			 (nn-send socreq dat)
			 (let* ((res (nn-recv socreq)))
			   (set! success #t)
			   (set! result res)))
			   (set! result (db:string->obj res transport: 'nmsg))))
		       "send-recv"))
	 (timeout     (make-thread
		       (lambda ()
			 (let loop ((count 0))
			   (thread-sleep! 1)
			   (debug:print-info 1 "send-receive-raw, still waiting after " count " seconds...")
			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
			       (loop (+ count 1))))
			 (if keepwaiting
			     (begin
			       (print "timeout waiting for ping")
			       (thread-terminate! send-recv))))
		       "timeout")))
    ;; replace with condition-case?
    (handle-exceptions
     exn
     (set! result "timeout")
     (thread-start! timeout)
     (thread-start! send-recv)
     (thread-join! send-recv)
     (if success (thread-terminate! timeout)))
    ;; raise timeout error if timed out
    (vector success result)))
    (if success
	(if (and (vector? result)
		 (vector-ref result 0)) ;; did it fail at the server?
	    result                ;; nope, all good
	    (begin
	      (debug:print 0 "ERROR: error occured at server, info=" (vector-ref result 2))
	      (debug:print 0 " client call chain:")
	      (print-call-chain (current-error-port))
	      (debug:print 0 " server call chain:")
	      (pp (vector-ref result 1) (current-error-port))
	      (signal (vector-ref result 0))))
	(signal (make-composite-condition
		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))

;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
︙
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

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








+

















-
+

-
-
-
+
+
+

-
+








		  (current-seconds)))
            (begin
              (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
              (loop 0))
            (begin
              (debug:print-info 0 "Starting to shutdown the server.")
              (set! *time-to-exit* #t)
	      (db:sync-touched *inmemdb* run-id force-sync: #t)
              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
              (debug:print-info 0 "Server shutdown complete. Exiting")
              (exit)
	      ))))))

;;======================================================================
;; C L I E N T S
;;======================================================================

(define (nmsg-transport:client-connect iface portnum)
  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
    (vector iface portnum #f #f #f (current-seconds) reqsoc)))

;; return #( success result )
;;
(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
  (mutex-lock! *http-mutex*)
  (let* ((packet  (db:obj->string (vector cmd param) transport: 'nmsg))
  (let* ((packet  (vector cmd param))
	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
	 (rawres  (nmsg-transport:client-api-send-receive-raw reqsoc packet))
	 (status  (vector-ref rawres 0))
	 (result  (vector-ref rawres 1)))
	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
;;	 (status  (vector-ref rawres 0))
;;	 (result  (vector-ref rawres 1)))
    (mutex-unlock! *http-mutex*)
    (vector status (if status (db:string->obj result transport: 'nmsg) result))))
    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
	
;;======================================================================
;; J U N K 
;;======================================================================

;; DO NOT USE
;;
︙

Modified rmt.scm from [dbecc93316] to [a3d9fb386a].

︙
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

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








-
+
-




-
-
+
+
+
+






-
-
+
+








  ;;            (begin
  ;;              (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
  ;;              ;; SHOULD CLOSE THE CONNECTION HERE
  ;;              (hash-table-delete! *runremote* run-id)))))
  ;;    (hash-table-keys *runremote*)))
  (mutex-unlock! *db-multi-sync-mutex*)
  (let* ((run-id          (if rid rid 0))
	 (connection-info (rmt:get-connection-info run-id))
	 (connection-info (rmt:get-connection-info run-id)))
	 (jparams         (db:obj->string params)))
    ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
    (if connection-info
	;; use the server if have connection info
	(let* ((dat     (case *transport-type*
			  ((http)(http-transport:client-api-send-receive run-id connection-info cmd jparams))
			  ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info cmd params))
			  ((http)(http-transport:client-api-send-receive run-id connection-info cmd params))
			  ((nmsg)(condition-case
				  (nmsg-transport:client-api-send-receive run-id connection-info cmd params)
				  ((timeout)(vector #f "timeout talking to server"))))
			  (else  (exit))))
	       (success (if (and dat (vector? dat)) (vector-ref dat 0) #f))
	       (res     (if (and dat (vector? dat)) (vector-ref dat 1) #f)))
	  (http-transport:server-dat-update-last-access connection-info)
	  (if success
	      (case *transport-type* 
		((http)(db:string->obj res))
		((nmsg)(vector-ref res 1)))
		((http) res) ;; (db:string->obj res))
		((nmsg) res)) ;; (vector-ref res 1)))
	      (begin ;; let ((new-connection-info (client:setup run-id)))
		(debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
		;; (case *transport-type*
		;;   ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info))))
		(hash-table-delete! *runremote* run-id) ;; don't keep using the same connection
		(if (eq? (modulo attemptnum 5) 0)
		    (tasks:kill-server-run-id run-id tag: "api-send-receive-failed"))
︙
251
252
253
254
255
256
257

258
259
260
261
262
263
264

252
253
254
255
256
257
258
259
260
261
262
263
264
265
266








+








;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
  (case *transport-type*
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
    ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))))

;; hand off a call to one of the db:queries statements
︙

Modified tests/unittests/basicserver.scm from [4e0a526d82] to [8806c7e3ae].

︙
12
13
14
15
16
17
18
19

20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35
36

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53


54
55
56
57
58
59
60

12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

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








-
+




+












-
+
















-
+
+








(test "setup for run" #t (begin (launch:setup-for-run)
 				(string? (getenv "MT_RUN_AREA_HOME"))))

;; NON Server tests go here

(test #f #f (db:dbdat-get-path *db*))
(test #f #f (db:get-run-name-from-id *db* run-id))
(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys))

;; (exit)

;; Server tests go here 
(for-each (lambda (run-id)
(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
(server:kind-run run-id)
(test "did server start within 20 seconds?"
      #t
      (let loop ((remtries 20)
		 (running (tasks:server-running-or-starting? (db:delay-if-busy
							      (tasks:open-db))
							     run-id)))
	(if running 
	    (> running 0)
	    (if (> remtries 0)
		(begin
		  (thread-sleep! 1.1)
		  (thread-sleep! 1)
		  (loop (- remtries 1)
			(tasks:server-running-or-starting? (db:delay-if-busy
							    (tasks:open-db))
							   run-id)))))))

(test "did server become available" #t
      (let loop ((remtries 10)
		 (res      (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
	(if res
	    (vector? res)
	    (begin
	      (if (> remtries 0)
		  (begin
		    (thread-sleep! 1.1)
		    (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
		  res)))))

)
(list 0 1))
(define user    (current-user-name))
(define runname "mytestrun")
(define keys    (rmt:get-keys))
(define runinfo #f)
(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
(define header  (vector "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
︙
98
99
100
101
102
103
104

105
106
107
108
109
110


111
112
113
114
115
116
117

100
101
102
103
104
105
106
107
108
109
110
111
112

113
114
115
116
117
118
119
120
121








+





-
+
+








      (let ((run-info (rmt:get-run-info run-id)))
	(db:get-value-by-header (db:get-rows run-info)
				(db:get-header run-info)
				"runname")))

      ;; (vector header (vector "abc" "def" 1 "mytestrun" "new" "n/a" "matt" 1416280640.0))

(for-each (lambda (run-id)
;; test killing server
;;
(tasks:kill-server-run-id run-id)

(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))

)
(list 0 1))
;; (test #f #f (client:setup run-id))

;; (set! *transport-type* 'http)
;; 
;; (test "setup for run" #t (begin (launch:setup-for-run)
;; 				(string? (getenv "MT_RUN_AREA_HOME"))))
;;
︙

Modified utils/plot-code.scm from [e7d92b1b39] to [cd37a2db38]. 

1
2

3
4



5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22


23
24
25
26
27
28
29

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35



+


+
+
+


















+
+








#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq

;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;;        dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan

(use regex srfi-69 srfi-13)

(define targs #f) 
(define files (cddddr (argv)))

(let ((targdat (cadddr (argv))))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))

(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))

(define all-fns '())

;; for the se

(define (print-err . data)
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print data))))

(print-err "Making graph for files: " (string-intersperse targs ", "))
︙
82
83
84
85
86
87
88
89






















90
91
92
93
94
95
96

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








-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








		    (loop (car tal)
			  (cdr tal)
			  newres)))
	      (if (null? tal)
		  res
		  (loop (car tal)(cdr tal) res)))))
      '()))
  

;; (define mm-header #<<MMHEADER
;; <map version="freeplane 1.2.0">
;; <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net -->
;; 
;; MMHEADER
;; 
;; (define (add-node text)
;;   <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955"><hook NAME="MapStyle">
;; )
;; 
;;  minimal mindmap file
;;  <map version="freeplane 1.2.0">
;;   <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net -->
;;   <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955">
;;   <node TEXT="node1" POSITION="right" ID="ID_1810107939" CREATED="1417113473476" MODIFIED="1417113480425">
;;   <node TEXT="node2" ID="ID_68133256" CREATED="1417113482134" MODIFIED="1417113484466"/>
;;   <node TEXT="node3" ID="ID_1572284821" CREATED="1417113487785" MODIFIED="1417113491589"/>
;;   </node>
;;   </node>
;;   </map>

;; Gather the usages
(print "digraph G {")
(define curr-cluster-num 0)
(define function-calls '())

(for-each
 (lambda (fname)
︙

This page was generated in about 0.126s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00