Overview
Comment: | Merged fork |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.80 |
Files: | files | file ages | folders |
SHA1: |
962cf22780a06669120491ef84913850 |
User & Date: | mrwellan on 2023-04-10 11:58:34 |
Other Links: | branch diff | manifest | tags |
Context
2023-04-10
| ||
16:16 | Some updates from code review check-in: 448f45b91b user: mrwellan tags: v1.80 | |
11:58 | Merged fork check-in: 962cf22780 user: mrwellan tags: v1.80 | |
07:58 | fixed start up wedging check-in: ce4cc8997a user: matt tags: v1.80 | |
2023-04-09
| ||
13:27 | Added host name to messages about server not started check-in: 21f45d51cf user: mmgraham tags: v1.80 | |
Changes
Modified dbfile.scm from [e15e8c336a] to [0519b94385].
︙ | ︙ | |||
1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 | ;; to get the lock ;; (define (dbfile:simple-file-lock fname #!key (expire-time 300)) (let ((fmod-time (handle-exceptions ext (current-seconds) (file-modification-time fname)))) (if (file-exists? fname) (if (> (- (current-seconds) fmod-time) expire-time) (begin (handle-exceptions exn #f (delete-file* fname)) (dbfile:simple-file-lock fname expire-time: expire-time)) | > > > | > > > | | | | > > > | > > | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 | ;; to get the lock ;; (define (dbfile:simple-file-lock fname #!key (expire-time 300)) (let ((fmod-time (handle-exceptions ext (current-seconds) (file-modification-time fname)))) ;; if the file exists, if it has expired, delete it and call this function recursively. (if (file-exists? fname) (if (> (- (current-seconds) fmod-time) expire-time) (begin (dbfile:print-err "simple-file-lock: removing expired file: " fname) (handle-exceptions exn #f (delete-file* fname)) (dbfile:simple-file-lock fname expire-time: expire-time)) #f ) ;; If it doesn't exist, write the host name and process id to the file (let ((key-string (conc (get-host-name) "-" (current-process-id) ": " (argv))) (oup (open-output-file fname))) (with-output-to-port oup (lambda () (print key-string))) (close-output-port oup) ;; sleep 3 seconds and make sure it still exists and contains the same host/process id. ;; if not, return #f (thread-sleep! 0.25) (if (file-exists? fname) (handle-exceptions exn #f (with-input-from-file fname (lambda () (equal? key-string (read-line))))) (begin (dbfile:print-err "dbfile:simple-file-lock created " fname " but it was gone 3 seconds later") #f ) ) ) ) ) ) (define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300)) (let ((end-time (+ expire-time (current-seconds)))) |
︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 | (define (dbfile:simple-file-release-lock fname) (handle-exceptions exn #f ;; I don't really care why this failed (at least for now) (delete-file* fname))) (define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300)) | > | > > > > | > > > > | < | 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 | (define (dbfile:simple-file-release-lock fname) (handle-exceptions exn #f ;; I don't really care why this failed (at least for now) (delete-file* fname))) (define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300)) (let ((start-time (current-seconds)) (gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time)) (end-time (current-seconds)) ) (if gotlock (let ((res (proc))) (dbfile:simple-file-release-lock fname) res) (begin (dbfile:print-err "dbfile:with-simple-file-lock: " fname " is locked by " (with-input-from-file fname (lambda () (dbfile:print-err (read-line))))) (dbfile:print-err "wait time = " (- end-time start-time)) (dbfile:print-err "ERROR: simple file lock could not get a lock for " fname " in " expire-time " seconds") #f ) ) ) ) (define *get-cache-stmth-mutex* (make-mutex)) (define (db:get-cache-stmth dbdat db stmt) (mutex-lock! *get-cache-stmth-mutex*) (let* (;; (dbdat (dbfile:get-dbdat dbstruct run-id)) (stmt-cache (dbr:dbdat-stmt-cache dbdat)) |
︙ | ︙ |
Modified tcp-transportmod.scm from [f46139fb7e] to [456ca5eb0a].
︙ | ︙ | |||
704 705 706 707 708 709 710 | (assert mtexe "FATAL: tt:server-process-run called without mtexe defined.") ;; mtest -server - -m testsuite:ext-tests -db 6.db (let* ((dbfname (dbmod:run-id->dbfname run-id)) (load (get-normalized-cpu-load)) (nrun (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname)))) (cond ((> load 2.0) | | | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 | (assert mtexe "FATAL: tt:server-process-run called without mtexe defined.") ;; mtest -server - -m testsuite:ext-tests -db 6.db (let* ((dbfname (dbmod:run-id->dbfname run-id)) (load (get-normalized-cpu-load)) (nrun (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname)))) (cond ((> load 2.0) (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server.") (thread-sleep! 1)) ((> nrun 100) (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.") (thread-sleep! 1)) (else (if (not (file-exists? (conc areapath"/logs"))) (create-directory (conc areapath"/logs") #t)) (let* ((logfile (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log")) (cmdln (conc mtexe |
︙ | ︙ |