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
|
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (common:get-linktree))
(tmp-area (common:get-db-tmp-area))
(start-file (conc tmp-area "/.server-start")))
(debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
;; set some parameters for the server
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
(handle-directory spiffy-directory-listing)
(handle-exception (lambda (exn chain)
(signal (make-composite-condition
(make-property-condition
'server
'message "server error")))))
;; Setup the web server and a /ctrl interface
;;
(vhost-map `(((* any) . ,(lambda (continue)
;; open the db on the first call
;; This is were we set up the database connections
(let* (($ (request-vars source: 'both))
(dat ($ 'dat))
(res #f))
(cond
((equal? (uri-path (request-uri (current-request)))
'(/ "api"))
(send-response ;; the $ is the request vars proc
body: ((api-proc) *dbstruct-db* $) ;; ($) => alist
headers: '((content-type text/plain)))
(set! *db-last-access* (current-seconds)))
((equal? (uri-path (request-uri (current-request)))
'(/ "ping"))
(send-response body: (conc *toppath*"/"(args:get-arg "-db"))
|
|
|
>
|
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
|
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (common:get-linktree))
(tmp-area (common:get-db-tmp-area))
#;(start-file (conc tmp-area "/.server-start")))
(debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
;; set some parameters for the server
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
(handle-directory spiffy-directory-listing)
#;(handle-exception (lambda (exn chain)
(signal (make-composite-condition
(make-property-condition
'server
'message "server error")))))
;; Setup the web server and a /ctrl interface
;;
(vhost-map `(((* any) . ,(lambda (continue)
;; open the db on the first call
;; This is were we set up the database connections
(let* (($ (request-vars source: 'both))
(dat ($ 'dat))
(res #f))
(cond
((equal? (uri-path (request-uri (current-request)))
'(/ "api"))
(debug:print 0 *default-log-port* "In api request $=" $)
(send-response ;; the $ is the request vars proc
body: ((api-proc) *dbstruct-db* $) ;; ($) => alist
headers: '((content-type text/plain)))
(set! *db-last-access* (current-seconds)))
((equal? (uri-path (request-uri (current-request)))
'(/ "ping"))
(send-response body: (conc *toppath*"/"(args:get-arg "-db"))
|
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
|
(mutex-lock! *http-mutex*)
(set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
;; serverdat contains uuid to be used for connection validation
;;
;; NOTE: serverdat must be initialized or created by servdat-init
;;
#;(define (http-transport:send-receive sdat qry-key cmd params #!key (numretries 3))
(let* ((res #f)
(success #t)
(sparams (with-output-to-string
(lambda ()(write params)))))
;; send the data and get the response extract the needed info from
;; the http data and process and return it.
(let* ((send-recieve (lambda ()
(set! res
(vector
#t ;; success
(with-input-from-request
(servdat-api-uri sdat)
(list (cons 'key qry-key)
;; (cons 'srvid (servdat-uuid sdat))
(cons 'cmd cmd)
(cons 'params sparams))
read-string))))) ;; or read-string?
(time-out (lambda ()
(thread-sleep! 45)
(debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
#f))
(th1 (make-thread send-recieve "with-input-from-request"))
(th2 (make-thread time-out "time out")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(close-idle-connections!)
(thread-terminate! th2)
(if (string? res)
(with-input-from-string res
(lambda () read))
res))))
|
>
>
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
|
(mutex-lock! *http-mutex*)
(set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
;; serverdat contains uuid to be used for connection validation
;;
;; NOTE: serverdat must be initialized or created by servdat-init
;;
;; DO NOT USE. Moved to rmt:set-receive-real
;;
;; (define (http-transport:send-receive conn qry-key cmd params #!key (numretries 3))
;; (let* ((res #f)
;; (success #t)
;; (sparams (with-output-to-string
;; (lambda ()(write params)))))
;; ;; send the data and get the response extract the needed info from
;; ;; the http data and process and return it.
;; (let* ((send-recieve (lambda ()
;; (set! res
;; (with-input-from-request
;; (rmt:conn->uri conn "api")
;; (list (cons 'key qry-key)
;; ;; (cons 'srvid (servdat-uuid sdat))
;; (cons 'cmd cmd)
;; (cons 'params sparams))
;; read-string))))
;; (time-out (lambda ()
;; (thread-sleep! 45)
;; (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
;; #f))
;; (th1 (make-thread send-recieve "with-input-from-request"))
;; (th2 (make-thread time-out "time out")))
;; (thread-start! th1)
;; (thread-start! th2)
;; (thread-join! th1)
;; (close-idle-connections!)
;; (thread-terminate! th2)
;; (if (string? res)
;; (with-input-from-string res
;; (lambda () read))
;; res))))
;; careful closing of connections stored in *runremote*
;;
(define (http-transport:close-connections #!key (area-dat #f))
(debug:print-info 0 *default-log-port* "http-transport:close-connections doesn't do anything now!"))
;; (let* ((runremote (or area-dat *runremote*))
;; (server-dat (if runremote
|