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
|
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
|
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
-
+
+
+
+
+
+
+
|
;; can use this to run most anything at the remote
(rpc:publish-procedure!
'remote:run
(lambda (procstr . params)
(server:autoremote procstr params)))
(rpc:publish-procedure!
'serve:login
(lambda (toppath)
(set! *last-db-access* (current-seconds))
(if (equal? *toppath* toppath)
(begin
(debug:print 2 "INFO: login successful")
#t)
#f)))
;;======================================================================
;; db specials here
;;======================================================================
;; remote call to open-run-close
(rpc:publish-procedure!
'rdb:open-run-close
(lambda (procname . remargs)
(debug:print 4 "INFO: rdb:open-run-close " procname " " remargs)
(debug:print 4 "INFO: Remote call of rdb:open-run-close " procname " " remargs)
(set! *last-db-access* (current-seconds))
(apply open-run-close (eval procname) remargs)))
(rpc:publish-procedure!
'cdb:test-set-status-state
(lambda (test-id status state)
(debug:print 4 "INFO: cdb:test-set-status-state " test-id " " status "/" state)
(apply cdb:test-set-status-state test-id status statue)))
(lambda (test-id status state msg)
(debug:print 4 "INFO: Remote call of cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg)
(cdb:test-set-status-state test-id status state msg)))
(rpc:publish-procedure!
'cdb:test-rollup-iterated-pass-fail
(lambda (test-id)
(debug:print 4 "INFO: cdb:test-rollup-iterated-pass-fail " test-id)
(debug:print 4 "INFO: Remote call of cdb:test-rollup-iterated-pass-fail " test-id)
(apply cdb:test-rollup-iterated-pass-fail test-id)))
(rpc:publish-procedure!
'cdb:pass-fail-counts
(lambda (test-id fail-count pass-count)
(debug:print 4 "INFO: Remote call of cdb:pass-fail-counts " test-id " passes: " pass-count " fails: " fail-count)
(apply cdb:pass-fail-counts test-id fail count-pass-count)))
;;======================================================================
;; end of publish-procedure section
;;======================================================================
(set! *rpc:listener* rpc:listener)
(on-exit (lambda ()
(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)
|
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
-
+
|
(define (server:keep-running db)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 20) ;; no need to do this very often
(let ((numrunning (db:get-count-tests-running db)))
(if (or (not (> numrunning 0))
(> *last-db-access* (+ (current-seconds) 20)))
(> *last-db-access* (+ (current-seconds) 60)))
(begin
(debug:print 0 "INFO: Starting to shutdown the server side")
(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"); ;; AND val like ?;"
;; host:port) ;; need to delete only *my* server entry (future use)
(thread-sleep! 10)
(debug:print 0 "INFO: Server shutdown complete. Exiting")
(exit))))
|
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
+
-
-
-
-
-
+
+
+
+
+
|
(if (and port
(string->number port))
(let ((portn (string->number port)))
(debug:print 2 "INFO: Setting up to connect to host " host ":" port)
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port)
(print "Exception: " ((condition-property-accessor 'exn 'message) exn))
(open-run-close
(lambda (db . param)
(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
#f)
(debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; (open-run-close
;; (lambda (db . param)
;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
;; #f)
(set! *runremote* #f))
(if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
((rpc:procedure 'serve:login host portn) *toppath*))
(begin
(debug:print 2 "INFO: Connected to " host ":" port)
(set! *runremote* (vector host portn)))
(begin
(debug:print 2 "INFO: Failed to connect to " host ":" port)
(set! *runremote* #f)))))
(debug:print 2 "INFO: no server available")))))
|