Differences From Artifact [04727fe923]:
- File client.scm — part of check-in [3e016c5af5] at 2023-01-12 20:02:19 on branch v1.80 — More close-connections fixes. (user: matt, size: 5840) [annotate] [blame] [check-ins using]
To Artifact [c0f004bcfc]:
- File
client.scm
— part of check-in
[67b18cc991]
at
2023-01-16 10:00:35
on branch v1.80-refactor
— Major refactor/clean up of client connection stuff. Removed old crufty approach of having both client and server side calls in http-transport. Plan would be to eventually get rid of http-transport.
Open files slowly grows. bad argument type in http-transport. Line 285 (close-connection! fullurl) is wrong. (user: matt, size: 7092) [annotate] [blame] [check-ins using]
| ︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
(declare (unit client))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(include "common_records.scm")
(include "db_records.scm")
;; client:get-signature
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
;; Not currently used! But, I think it *should* be used!!!
#;(define (client:logout serverdat)
(let ((ok (and (socket? serverdat)
(cdb:logout serverdat *toppath* (client:get-signature)))))
ok))
| > > > > > > > < < < > > > > > > > > > > | | | | | > > | < | | > > | | > | | > | | < | < | | < | | | | | | > > > > > > > > > > > > > > > > > > > > > > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 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 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 |
(declare (unit client))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(module client
*
)
(import client)
(include "common_records.scm")
(include "db_records.scm")
;; client:get-signature
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
;; Not currently used! But, I think it *should* be used!!!
#;(define (client:logout serverdat)
(let ((ok (and (socket? serverdat)
(cdb:logout serverdat *toppath* (client:get-signature)))))
ok))
;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios.
;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;; 2. We are a run tests, list runs or other interactive process and we must figure out
;; *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
;;
;; lookup_server, need to remove *runremote* stuff
;;
;;(define (http-transport:server-dat-make-url runremote)
(define (client:get-url runremote)
(if (and (remote-iface runremote)
(remote-port runremote))
(conc "http://"
(remote-iface runremote)
":"
(remote-port runremote))
#f))
(define (client:setup areapath runremote #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
(mutex-lock! *rmt-mutex*)
(let ((res (client:setup-http areapath runremote remaining-tries: remaining-tries failed-connects: failed-connects area-dat: area-dat)))
(mutex-unlock! *rmt-mutex*)
res))
(define (client:setup-http areapath runremote #!key (remaining-tries 100) (failed-connects 0))
(debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
(server:start-and-wait areapath)
(if (<= remaining-tries 0)
(begin
(debug:print-error 0 *default-log-port* "failed to start or connect to server")
(exit 1))
;;
;; Alternatively here, we can get the list of candidate servers and work our way
;; through them searching for a good one.
;;
(let* ((server-dat (server:choose-server areapath 'best))) ;; list host port start-time server-id pid
;; (runremote (or area-dat *runremote*)))
(if (not server-dat) ;; no server found
(begin
(if (< remaining-tries 99)(thread-sleep! 1)) ;; obviously it needs time
(client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
(match server-dat
((host port start-time server-id pid)
(debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if (not runremote)
(begin
;; Here we are creating a runremote where there was none or it was clobbered with #f
;;
(set! runremote (make-remote))
(let* ((server-info (server:check-if-running areapath)))
(remote-server-info-set! runremote server-info)
(if server-info
(begin
(remote-server-url-set! runremote (server:record->url server-info))
(remote-server-id-set! runremote (server:record->id server-info)))))))
;; at this point we have a runremote
(if (and host port server-id)
(let* ((nada (client:connect host port server-id runremote))
(ping-res (rmt:login-no-auto-client-setup runremote)))
(if ping-res
(if runremote
(begin
(debug:print-info 2 *default-log-port* "connected to " (client:get-url runremote))
runremote)
(client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
(begin ;; login failed but have a server record, clean out the record and try again
(debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
(http-transport:close-connections runremote)
(thread-sleep! 1)
(client:setup-http-baby areapath runremote remaining-tries: (- remaining-tries 1))
)))
(begin ;; no server registered
;; (server:kind-run areapath)
(server:start-and-wait areapath)
(debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
(thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
(client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))))
(else
(debug:print 0 *default-log-port* "ERROR: malformed server-dat="server-dat)))))))
;;
;; connect - stored in remote-condat
;;
;; (define (http-transport:client-connect iface port server-id runremote)
(define (client:connect iface port server-id runremote-in)
(let* ((runremote (or runremote-in
(make-runremote))))
(debug:print-info 2 *default-log-port* "Connecting to server at "iface":"port", id "server-id)
(let* ((api-url (conc "http://" iface ":" port "/api"))
(api-uri (uri-reference (conc "http://" iface ":" port "/api")))
(api-req (make-request method: 'POST uri: api-uri)))
;; (server-dat (vector iface port api-uri api-url api-req (current-seconds) server-id)))
(remote-iface-set! runremote iface)
(remote-port-set! runremote port)
(remote-server-id-set! runremote server-id)
(remote-connect-time-set! runremote (current-seconds))
(remote-last-access-set! runremote (current-seconds))
(remote-api-url-set! runremote api-url)
(remote-api-uri-set! runremote api-uri)
(remote-api-req-set! runremote api-req)
runremote)))
|