15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
(require-extension (srfi 18) extras tcp) ;; rpc)
;; (import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
|
>
>
>
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
(require-extension (srfi 18) extras tcp) ;; rpc)
;; (import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
;; Note, try to remove this dependency
(use zmq)
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
|
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
|
;; (define (db:updater)
;; (debug:print-info 4 "Starting cache processing")
;; (let loop ()
;; (thread-sleep! 10) ;; move save time around to minimize regular collisions?
;; (db:write-cached-data)
;; (loop)))
(define (db:obj->string obj)
(string-substitute
(regexp "=") "_"
(base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
#t))
(define (db:string->obj msg)
(with-input-from-string
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t))
(lambda ()(deserialize))))
(define (cdb:use-non-blocking-mode proc)
(set! *client-non-blocking-mode* #t)
(let ((res (proc)))
(set! *client-non-blocking-mode* #f)
res))
|
>
>
>
>
|
|
|
|
>
>
>
>
>
|
|
|
|
|
>
>
|
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
|
;; (define (db:updater)
;; (debug:print-info 4 "Starting cache processing")
;; (let loop ()
;; (thread-sleep! 10) ;; move save time around to minimize regular collisions?
;; (db:write-cached-data)
;; (loop)))
;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
(case *transport-type*
((fs) obj)
((http)
(string-substitute
(regexp "=") "_"
(base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
#t))
((zmq)(with-output-to-string (lambda ()(serialize obj))))
(else obj)))
(define (db:string->obj msg)
(case *transport-type*
((fs) msg)
((http)
(with-input-from-string
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t))
(lambda ()(deserialize))))
((zmq)(with-input-from-string msg (lambda ()(deserialize))))
(else msg)))
(define (cdb:use-non-blocking-mode proc)
(set! *client-non-blocking-mode* #t)
(let ((res (proc)))
(set! *client-non-blocking-mode* #f)
res))
|
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
|
(zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params))))
(debug:print-info 11 "zdat=" zdat)
(let* ((res #f)
(rawdat (server:client-send-receive serverdat zdat))
(tmp #f))
(debug:print-info 11 "Sent " zdat ", received " rawdat)
(set! tmp (db:string->obj rawdat))
(vector-ref tmp 2)
)))))
(define (cdb:set-verbosity serverdat val)
(cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))
(define (cdb:login serverdat keyval signature)
(cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
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
1222
1223
1224
1225
|
(zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params))))
(debug:print-info 11 "zdat=" zdat)
(let* ((res #f)
(rawdat (server:client-send-receive serverdat zdat))
(tmp #f))
(debug:print-info 11 "Sent " zdat ", received " rawdat)
(set! tmp (db:string->obj rawdat))
(vector-ref tmp 2))))
((zmq)
(handle-exceptions
exn
(begin
(thread-sleep! 5)
(if (> numretries 0)(apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params)))
(let* ((push-socket (vector-ref zmq-sockets 0))
(sub-socket (vector-ref zmq-sockets 1))
(client-sig (server:get-client-signature))
(query-sig (message-digest-string (md5-primitive) (conc qtype immediate params)))
(zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params))))
(res #f)
(send-receive (lambda ()
(debug:print-info 11 "sending message")
(send-message push-socket zdat)
(debug:print-info 11 "message sent")
(let loop ()
;; get the sender info
;; this should match (server:get-client-signature)
;; we will need to process "all" messages here some day
(receive-message* sub-socket)
;; now get the actual message
(let ((myres (db:string->obj (receive-message* sub-socket))))
(if (equal? query-sig (vector-ref myres 1))
(set! res (vector-ref myres 2))
(loop))))))
(timeout (lambda ()
(let loop ((n numretries))
(thread-sleep! 15)
(if (not res)
(if (> numretries 0)
(begin
(debug:print 2 "WARNING: no reply to query " params ", trying resend")
(debug:print-info 11 "re-sending message")
(send-message push-socket zdat)
(debug:print-info 11 "message re-sent")
(loop (- n 1)))
;; (apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params))
(begin
(debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
(exit 5))))))))
(debug:print-info 11 "Starting threads")
(let ((th1 (make-thread send-receive "send receive"))
(th2 (make-thread timeout "timeout")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(debug:print-info 11 "cdb:client-call returning res=" res)
res))))))
(define (cdb:set-verbosity serverdat val)
(cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))
(define (cdb:login serverdat keyval signature)
(cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))
|