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
|
(define (server:main-loop)
(print "INFO: Exectuing main server loop")
(access-log "megatest-http.log")
(server-bind-address #f)
(define-page (main-page-path)
(lambda ()
(with-request-variables (dat)
(debug:print-info 12 "Got dat=" dat)
(let* ((packet (db:string->obj dat))
(qtype (cdb:packet-get-qtype packet)))
(debug:print-info 12 "server=> received packet=" packet)
(if (not (member qtype '(sync ping)))
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)))
(open-run-close db:process-queue-item open-db packet))))))
;; This is recursively run by server:run until sucessful
;;
(define (server:try-start-server ipaddrstr portnum)
(handle-exceptions
exn
(begin
|
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
(define (server:main-loop)
(print "INFO: Exectuing main server loop")
(access-log "megatest-http.log")
(server-bind-address #f)
(define-page (main-page-path)
(lambda ()
(let ((dat ($ "dat")))
;; (with-request-variables (dat)
(debug:print-info 12 "Got dat=" dat)
(let* ((packet (db:string->obj dat))
(qtype (cdb:packet-get-qtype packet)))
(debug:print-info 12 "server=> received packet=" packet)
(if (not (member qtype '(sync ping)))
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)))
(let ((res (open-run-close db:process-queue-item open-db packet)))
(debug:print-info 11 "Return value from db:process-queue-item is " res)
res))))))
;;; (use spiffy uri-common intarweb)
;;;
;;; (root-path "/var/www")
;;;
;;; (vhost-map `(((* any) . ,(lambda (continue)
;;; (if (equal? (uri-path (request-uri (current-request)))
;;; '(/ "hey"))
;;; (send-response body: "hey there!\n"
;;; headers: '((content-type text/plain)))
;;; (continue))))))
;;;
;;; (start-server port: 12345)
;; This is recursively run by server:run until sucessful
;;
(define (server:try-start-server ipaddrstr portnum)
(handle-exceptions
exn
(begin
|
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (server:client-send-receive serverdat msg)
(let* ((url (server:make-server-url serverdat))
(fullurl (conc url "/?dat=" msg)))
(debug:print-info 11 "fullurl=" fullurl "\n")
(let* ((res (with-input-from-request fullurl #f read-string)))
(debug:print-info 11 "got res=" res)
(let ((match (string-search (regexp "<body>(.*)<.body>") res)))
(debug:print-info 11 "match=" match)
(let ((final (cadr match)))
(debug:print-info 11 "final=" final)
final)))))
|
|
|
>
>
>
>
|
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (server:client-send-receive serverdat msg)
(let* ((url (server:make-server-url serverdat))
(fullurl url)) ;; (conc url "/?dat=" msg)))
(debug:print-info 11 "fullurl=" fullurl "\n")
(let* ((res (with-input-from-request fullurl
;; #f
;; msg
(list (cons 'dat msg))
read-string)))
(debug:print-info 11 "got res=" res)
(let ((match (string-search (regexp "<body>(.*)<.body>") res)))
(debug:print-info 11 "match=" match)
(let ((final (cadr match)))
(debug:print-info 11 "final=" final)
final)))))
|
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
|
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
(thread-sleep! 1)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)))))))
|
<
<
|
284
285
286
287
288
289
290
291
292
293
294
295
296
297
|
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
(thread-sleep! 1)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)))))))
;; all routes though here end in exit ...
(define (server:launch)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
|