Overview
Comment: | Try switching to tcp6 |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.6584-tcp6 |
Files: | files | file ages | folders |
SHA1: |
2f294c2d840b0ec231c93e439ebeb07c |
User & Date: | matt on 2021-05-24 22:29:00 |
Other Links: | branch diff | manifest | tags |
Context
2021-05-24
| ||
22:39 | wip check-in: ccd3ea6a35 user: matt tags: v1.6584-tcp6 | |
22:29 | Try switching to tcp6 check-in: 2f294c2d84 user: matt tags: v1.6584-tcp6 | |
04:16 | wip Leaf check-in: 82185ccf67 user: matt tags: v1.6584-ck5 | |
Changes
Modified rmtmod.scm from [19d96827e3] to [f9d9cfcea7].
︙ | ︙ | |||
55 56 57 58 59 60 61 | chicken.string chicken.tcp chicken.random chicken.time chicken.time.posix (prefix sqlite3 sqlite3:) directory-utils | | | | | | > | 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 | chicken.string chicken.tcp chicken.random chicken.time chicken.time.posix (prefix sqlite3 sqlite3:) directory-utils ;; http-client ;; intarweb matchable md5 message-digest (prefix base64 base64:) (prefix sqlite3 sqlite3:) regex s11n ;; spiffy ;; spiffy-directory-listing ;; spiffy-request-vars srfi-1 srfi-13 srfi-18 srfi-69 stack system-information tcp6 typed-records uri-common z3 apimod clientmod commonmod |
︙ | ︙ | |||
108 109 110 111 112 113 114 | ;; ;; ;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; ;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; ;; Configurations for server | | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | ;; ;; ;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; ;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; ;; Configurations for server ;; (tcp-buffer-size 2048) ;; (max-connections 2048) ;; info about me as a server ;; (defstruct servdat (host #f) (port #f) (uuid #f) |
︙ | ︙ | |||
253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | (if (list? res) ;; server has been registered and the info was returned. pass it on. res (begin (debug:print-info 0 *default-log-port* "Unexpected result: " res) res))))))))) ;;====================================================================== ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (rmt:general-open-connection conns apath dbname) (rmt:send-receive-real conns apath dbname cmd params))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future ;; | > > > > > > | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | (if (list? res) ;; server has been registered and the info was returned. pass it on. res (begin (debug:print-info 0 *default-log-port* "Unexpected result: " res) res))))))))) ;;====================================================================== ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (rmt:general-open-connection conns apath dbname) (rmt:send-receive-real conns apath dbname cmd params))) (define (rmt:send-receive-real host port data) (let-values ((i o) (tcp-connect "localhost" 4242)) (write-line "Good Bye!" o) (print (read-line i)))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future ;; #;(define (rmt:send-receive-real remote apath dbname cmd params) (let* ((conn (rmt:get-conn remote apath dbname))) (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened") (let* ((payload (sexpr->string params)) (res (with-input-from-request (rmt:conn->uri conn "api") `((params . ,payload) (cmd . ,cmd) |
︙ | ︙ | |||
290 291 292 293 294 295 296 | ;; ;; Purpose - call the main.db server and request a server be started ;; for the given area path and dbname ;; (define (rmt:send-receive-server-start remote apath dbname) (let* ((conn (rmt:get-conn remote apath dbname))) (assert conn "FATAL: Unable to connect to db "apath"/"dbname) | | | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 | ;; ;; Purpose - call the main.db server and request a server be started ;; for the given area path and dbname ;; (define (rmt:send-receive-server-start remote apath dbname) (let* ((conn (rmt:get-conn remote apath dbname))) (assert conn "FATAL: Unable to connect to db "apath"/"dbname) #;(let* ((res (with-input-from-request (rmt:conn->uri conn "api") `((params . (,apath ,dbname))) read-string))) (string->sexpr res)))) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" |
︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 | (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db (let ((db (cdr (bdat-task-db *bdat*)))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) (bdat-task-db-set! *bdat* #f))))) | | | 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 | (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db (let ((db (cdr (bdat-task-db *bdat*)))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) (bdat-task-db-set! *bdat* #f))))) #;(http-client#close-idle-connections!) (if (not (eq? *default-log-port* (current-error-port))) (close-output-port *default-log-port*)) (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry (begin |
︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 | (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet"))) (define (http-handle-api dbstruct $) (if (api-proc) ((api-proc) dbstruct $) ;; ($) => alist 'no-api-proc-set)) | > > > > > > > > | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 | (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet"))) (define (http-handle-api dbstruct $) (if (api-proc) ((api-proc) dbstruct $) ;; ($) => alist 'no-api-proc-set)) (define (rmt:launch-server hostn) (let* ((l (tcp-listen 4242))) (define-values (i o) (tcp-accept l)) (write-line "Hello!" o) (print (read-line i)) (close-input-port i) (close-output-port o))) #;(define (http-transport:run hostn) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) (debug:print 2 *default-log-port* "Attempting to start the server ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) |
︙ | ︙ | |||
1603 1604 1605 1606 1607 1608 1609 | (send-response body: ((http-get-function 'http-transport:html-dboard) $) headers: '((content-type text/HTML)))) (else (continue)))))))) (http-transport:try-start-server ipaddrstr start-port))) ;; This is recursively run by http-transport:run until sucessful, it then runs until server is stopped ;; | | | 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 | (send-response body: ((http-get-function 'http-transport:html-dboard) $) headers: '((content-type text/HTML)))) (else (continue)))))))) (http-transport:try-start-server ipaddrstr start-port))) ;; This is recursively run by http-transport:run until sucessful, it then runs until server is stopped ;; #;(define (http-transport:try-start-server ipaddrstr portnum) (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes"))) (if (not config-use-proxy) (determine-proxy (constantly #f))) ;; any error in following steps will result in a retry (if *server-info* (begin |
︙ | ︙ | |||
1697 1698 1699 1700 1701 1702 1703 | (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.052) (loop etime)) (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) | | | 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 | (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.052) (loop etime)) (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) #;(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*))) |
︙ | ︙ | |||
1844 1845 1846 1847 1848 1849 1850 | (alist-ref 'port srv-pkt))) (define (server-ready? host port key) ;; 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 '()))) | > | | > > > | | > > | 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 | (alist-ref 'port srv-pkt))) (define (server-ready? host port key) ;; 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* ((res (with-input-from-request (conc "http://"host":"port"/ping") ;; returns *toppath*/dbname #f read-string))) (if (equal? res key) #t (begin (debug:print-info 0 *default-log-port* "server-ready? key="key", received="res) #f))) #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") `((data . ,payload)) read-string))) (string->sexpr res)) #f ) ; 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) |
︙ | ︙ | |||
2195 2196 2197 2198 2199 2200 2201 | ;;(let* ((tmp-area (common:get-db-tmp-area)) ;; (server-start (conc tmp-area "/.server-start")) ;; (server-started (conc tmp-area "/.server-started")) ;; (start-time (common:lazy-modification-time server-start)) ;; (started-time (common:lazy-modification-time server-started)) ;; (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting ;; (start-time-old (> (- (current-seconds) start-time) 5)) | | | > > > | 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 | ;;(let* ((tmp-area (common:get-db-tmp-area)) ;; (server-start (conc tmp-area "/.server-start")) ;; (server-started (conc tmp-area "/.server-started")) ;; (start-time (common:lazy-modification-time server-start)) ;; (started-time (common:lazy-modification-time server-started)) ;; (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting ;; (start-time-old (> (- (current-seconds) start-time) 5)) #;(let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") )) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (http-transport:keep-running dbname) "Keep running")))) (thread-start! th2) (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) (exit)) #f ) ;; Generate a unique signature for this server (define (server:mk-signature) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) |
︙ | ︙ |