Overview
Comment: | Got loop-test working |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.6584-ck5 |
Files: | files | file ages | folders |
SHA1: |
ba4f089eda9e205654d8985e6fc9092b |
User & Date: | matt on 2021-05-10 22:53:37 |
Other Links: | branch diff | manifest | tags |
Context
2021-05-10
| ||
23:25 | Ripped up and rebuilt (but not completed) send-recieve check-in: 60d056bd58 user: matt tags: v1.6584-ck5 | |
22:53 | Got loop-test working check-in: ba4f089eda user: matt tags: v1.6584-ck5 | |
2021-05-09
| ||
23:42 | Simplify running of unit tests, simplified ping check-in: 0453b5d22b user: matt tags: v1.6584-ck5 | |
Changes
Modified http-transportmod.scm from [853954beaf] to [a2b5cd07dd].
︙ | ︙ | |||
173 174 175 176 177 178 179 180 181 182 183 184 185 186 | 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")) headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: ((http-get-function 'http-transport:main-page)))) ((equal? (uri-path (request-uri (current-request))) '(/ "json_api")) (send-response body: ((http-get-function 'http-transport:main-page)))) ((equal? (uri-path (request-uri (current-request))) '(/ "runs")) | > > > > | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | 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")) headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "loop-test")) (send-response body: (alist-ref 'data ($)) headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: ((http-get-function 'http-transport:main-page)))) ((equal? (uri-path (request-uri (current-request))) '(/ "json_api")) (send-response body: ((http-get-function 'http-transport:main-page)))) ((equal? (uri-path (request-uri (current-request))) '(/ "runs")) |
︙ | ︙ | |||
296 297 298 299 300 301 302 303 304 305 306 307 308 309 | (close-idle-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) (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) | > > > > > > > > | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | (close-idle-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) (define (sexpr->string data) (with-output-to-string (lambda ()(write data)))) (define (string->sexpr instr) (with-input-from-string instr (lambda ()(read)))) ;; 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) |
︙ | ︙ | |||
481 482 483 484 485 486 487 | read-string))) (if (equal? res key) #t (begin (debug:print-info 0 *default-log-port* "server-ready? key="key", received="res) #f)))) | > > > > > > > > > > > > | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 | read-string))) (if (equal? res key) #t (begin (debug:print-info 0 *default-log-port* "server-ready? key="key", received="res) #f)))) (define (loop-test host port data) ;; server-address is host:port ;; ping the server and ask it ;; if it ready ;; (let* ((sdat (servdat-init #f host port #f))) ;; (http-transport:send-receive sdat "abc" 'ping '()))) (let* ((payload (sexpr->string data)) (res (with-input-from-request (conc "http://"host":"port"/loop-test") ;; returns *toppath*/dbname `((data . ,payload)) read-string))) (string->sexpr res))) ; from the pkts return servers associated with dbpath ;; NOTE: Only one can be alive - have to check on each ;; in the list of pkts returned ;; (define (get-viable-servers serv-pkts dbpath) (let loop ((tail serv-pkts) (res '())) (if (null? tail) |
︙ | ︙ |
Modified rmtmod.scm from [e114506d72] to [e69c41a548].
︙ | ︙ | |||
155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | ) (defstruct rmt:conn (apath #f) (dbname #f) (fullname #f) (hostport #f) (lastmsg 0) (expires 0)) ;; replaces *runremote* (define *rmt:remote* (make-rmt:remote)) ;; set up the api proc, seems like there should be a better place for this? (api-proc api:process-request) ;; do we have a connection to apath dbname and ;; is it not expired? then return it ;; ;; else setup a connection ;; ;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception ;; (define (rmt:get-connection remote apath dbname) | > > > | | | | | > > > | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | ) (defstruct rmt:conn (apath #f) (dbname #f) (fullname #f) (hostport #f) (ipaddr #f) (port #f) (srvpkt #f) (lastmsg 0) (expires 0)) ;; replaces *runremote* (define *rmt:remote* (make-rmt:remote)) ;; set up the api proc, seems like there should be a better place for this? (api-proc api:process-request) ;; do we have a connection to apath dbname and ;; is it not expired? then return it ;; ;; else setup a connection ;; ;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception ;; (define (rmt:get-connection remote apath dbname) (let* ((fullname (db:dbname->path apath dbname)) ;; we'll switch to full name later (conn (hash-table-ref/default (rmt:remote-conns remote) dbname #f))) (if (and conn (< (current-seconds) (rmt:conn-expires conn))) conn #f))) (define (rmt:find-main-server apath dbname) (let* ((pktsdir (get-pkts-dir apath)) (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*)) (dbpath (conc apath "/" dbname)) (viable-srvs (get-viable-servers all-srvpkts dbpath))) (get-the-server viable-srvs))) ;; looks for a connection to main ;; connections for other servers happens by requesting from main ;; (define (rmt:open-main-connection remote apath) (let* ((dbname (db:run-id->dbname #f)) (the-srv (rmt:find-main-server apath dbname)) (start-main-srv (lambda () ;; srv not ready, delay a little and try again (system (conc "nbfake megatest -server - -area "apath " -db "dbname)) (thread-sleep! 2) (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries ))) (if the-srv ;; yes, we have a server, now try connecting to it (let* ((srv-addr (server-address the-srv)) (ipaddr (alist-ref 'ipaddr the-srv)) (port (alist-ref 'port the-srv)) (fullpath (db:dbname->path apath dbname)) (srvready (server-ready? ipaddr port fullpath))) (if srvready (begin (hash-table-set! (rmt:remote-conns remote) dbname ;; fullpath ;; yes, I'd prefer it to be fullpath - FIXME later (make-rmt:conn apath: apath dbname: dbname fullname: fullpath hostport: srv-addr ipaddr: ipaddr port: port srvpkt: the-srv lastmsg: (current-seconds) expires: (+ (current-seconds) 60) ;; this needs to be gathered during the ping )) #t) (start-main-srv))) (start-main-srv)))) |
︙ | ︙ |
Modified tests/unittests/basicserver.scm from [e95e668f31] to [6df38336e6].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Run like this: ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) | | > > > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Run like this: ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (import rmtmod trace http-transportmod) (trace-call-sites #t) (trace ;; rmt:find-main-server ) (test #f #t (rmt:remote? (let ((r (make-rmt:remote))) (set! *rmt:remote* r) r))) (test #f #f (rmt:get-connection *rmt:remote* *toppath* ".db/main.db")) (test #f #f (rmt:find-main-server *toppath* ".db/main.db")) (test #f #t (rmt:open-main-connection *rmt:remote* *toppath*)) (pp (hash-table->alist (rmt:remote-conns *rmt:remote*))) (test #f #t (rmt:conn? (rmt:get-connection *rmt:remote* *toppath* ".db/main.db"))) (define *main* (rmt:get-connection *rmt:remote* *toppath* ".db/main.db")) (test #f 'a (loop-test (rmt:conn-ipaddr *main*)(rmt:conn-port *main*) 'a)) ;; (delete-file* "logs/1.log") ;; (define run-id 1) ;; (test "setup for run" #t (begin (launch:setup) ;; (string? (getenv "MT_RUN_AREA_HOME")))) ;; |
︙ | ︙ |