1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use json)
(declare (unit rmt))
(declare (uses api))
(declare (uses tdb))
(declare (uses http-transport))
;;
|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use json format)
(declare (unit rmt))
(declare (uses api))
(declare (uses tdb))
(declare (uses http-transport))
;;
|
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
|
(if connection-info
(let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
(db:string->obj res)
(let ((new-connection-info (client:setup run-id)))
(debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
(rmt:send-receive cmd run-id params))))
(begin
(debug:print-info 4 "no server and read-only query, bypassing normal channel")
(if (rmt:write-frequency-over-limit? cmd run-id)(server:kind-run run-id))
(rmt:open-qry-close-locally cmd run-id params)))))
(define (rmt:update-db-stats cmd duration)
(mutex-lock! *db-stats-mutex*)
(let ((stat-vec (hash-table-ref/default *db-stats* cmd #f)))
(rmt:update-db-stats cmd duration)
res)))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(let* ((run-id (if run-id run-id 0))
(jparams (db:obj->string params)) ;; (rmt:dat->json-str params))
(res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
|
|
|
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
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
154
155
156
157
158
159
160
161
162
163
|
(if connection-info
(let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
(db:string->obj res)
(let ((new-connection-info (client:setup run-id)))
(debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
(rmt:send-receive cmd run-id params))))
(let ((max-avg-qry (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "800"))))
(debug:print-info 4 "no server and read-only query, bypassing normal channel")
;; (if (rmt:write-frequency-over-limit? cmd run-id)(server:kind-run run-id))
(let ((curr-max (rmt:get-max-query-average)))
(if (> (cdr curr-max) max-avg-qry)
(begin
(debug:print-info 0 "Max average query, " (inexact->exact (round (cdr curr-max))) "ms (" (car curr-max) ") exceeds " max-avg-qry ", try starting server ...")
(server:kind-run run-id))))
(rmt:open-qry-close-locally cmd run-id params)))))
(define (rmt:update-db-stats rawcmd params duration)
(mutex-lock! *db-stats-mutex*)
(let* ((cmd (if (eq? rawcmd 'general-call) (car params) rawcmd))
(stat-vec (hash-table-ref/default *db-stats* cmd #f)))
(if (not stat-vec)
(let ((newvec (vector 0 0)))
(hash-table-set! *db-stats* cmd newvec)
(set! stat-vec newvec)))
(vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1))
(vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))
(mutex-unlock! *db-stats-mutex*))
(define (rmt:print-db-stats)
(let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
(debug:print 18 "DB Stats\n========")
(debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
(for-each (lambda (cmd)
(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
(debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
(sort (hash-table-keys *db-stats*)
(lambda (a b)
(> (vector-ref (hash-table-ref *db-stats* a) 0)
(vector-ref (hash-table-ref *db-stats* b) 0)))))))
(define (rmt:get-max-query-average)
(mutex-lock! *db-stats-mutex*)
(let* ((cmds (hash-table-keys *db-stats*))
(res (if (null? cmds)
(cons 'none 0)
(let loop ((cmd (car cmds))
(tal (cdr cmds))
(max-cmd (car cmds))
(res 0))
;; (if (member cmd '(delete-tests-in-state)) ;; black list these outliers
;; (if (null? tal)
;; (if (> tot 20)
;; (cons
;;
(let* ((cmd-dat (hash-table-ref *db-stats* cmd))
(tot (vector-ref cmd-dat 0))
(curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
(currmax (max res curravg))
(newmax-cmd (if (> curravg res) cmd max-cmd)))
(if (null? tal)
(if (> tot 10)
(cons newmax-cmd currmax)
(cons 'none 0))
(loop (car tal)(cdr tal) newmax-cmd currmax)))))))
(mutex-unlock! *db-stats-mutex*)
res))
(define (rmt:open-qry-close-locally cmd run-id params)
(let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dbstruct-local (if *dbstruct-db*
*dbstruct-db*
(let ((db (make-dbr:dbstruct path: dbdir local: #t)))
(set! *dbstruct-db* db)
db)))
(db-file-path (db:dbfile-path 0)))
;; (read-only (not (file-read-access? db-file-path)))
(let* ((start (current-milliseconds))
(res (api:execute-requests dbstruct-local (symbol->string cmd) params))
(duration (- (current-milliseconds) start)))
(rmt:update-db-stats cmd params duration)
res)))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(let* ((run-id (if run-id run-id 0))
(jparams (db:obj->string params)) ;; (rmt:dat->json-str params))
(res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
|