16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(use srfi-69 posix)
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
|
|
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(use srfi-69 posix srfi-18)
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
|
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
(define *db-write-mutexes* (make-hash-table))
;; 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 dat)
(db:open-no-sync-db) ;; sets *no-sync-db*
;; (handle-exceptions
;; exn
;; (let ((call-chain (get-call-chain)))
;; (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
;; (print-call-chain (current-error-port))
;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
#;((> *api-process-request-count* 200) ;; 20)
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
(set! *server-overloaded* #t)
(vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
|
>
>
>
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<
<
<
<
<
|
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
(define *db-write-mutexes* (make-hash-table))
(define *api-watchdog* #f)
(define (api:watchdog dbstruct) ;; trim not-used sqlite3 db handles
(let* ((th1 (make-thread (lambda ()
(let loop ()
(thread-sleep! 60) ;; 2x the age we close at
(db:close-old dbstruct)
(loop)))
"api:watchdog thread")))
(thread-start! th1)
(set! *api-watchdog* th1)))
;; 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 dat)
(db:open-no-sync-db) ;; sets *no-sync-db*
(if (not *api-watchdog*)(api:watchdog dbstruct))
(if (> *api-process-request-count* 200)
(begin
(if (common:low-noise-print 30 "too many threads")
(debug:print 0 *default-log-port* "WARNING: "*api-process-request-count*" threads, potential overload, adding 0.5 sec delay."))
(thread-sleep! 0.5) ;; take a nap
))
(cond
((not (vector? dat)) ;; it is an error to not receive a vector
(vector #f (vector #f "remote must be called with a vector")))
(else
(let* ((cmd-in (vector-ref dat 0))
(cmd (if (symbol? cmd-in)
cmd-in
(string->symbol cmd-in)))
(params (vector-ref dat 1))
(run-id (if (null? params)
|