Megatest

;;======================================================================
;; setting/getting a lock on the db for only one server per db
;;
;;  NOTE:
;;       These operate directly on the disk file, NOT on the inmemory db
;;       The lockname is the filename (can have many to one, run-id to fname 
;;======================================================================

(define (with-lock-db dbfile proc)
  (let* ((dbh (db:open-run-db dbfile db:initialize-db))
	 (res (proc dbh dbfile)))
    (sqlite3:finalize! dbh)
    res))

;; called before db is open?
;;
(define (db:get-iam-server-lock dbh dbfname)
  (sqlite3:with-transaction
   dbh
   (lambda ()
     (let* ((locked (db:get-locker dbh dbfname)))
       (if (not locked)
	   (db:take-lock dbh dbfname)
     (let* ((locker (db:get-locker dbh dbfname)))
       (if locker
	   #f
	   (db:take-lock dbh dbfname))))))
	   #f)))))
	     
;; (exn sqlite3) 
(define (db:get-locker dbh dbfname)
  (condition-case
   (sqlite3:first-row dbh "SELECT owner_pid,owner_host,event_time FROM locks WHERE lockname=%;" dbfname)
   (exn (sqlite3) #f)))

;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

(defstruct servdat
  host
  port
  uuid)
  uuid
  dbfile
  )

(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

;;======================================================================

;;======================================================================
;; NEW SERVER METHOD
;;======================================================================

;; only use for main.db - need to re-write some of this :(
;;
(define (get-lock-db sdat dbfile)
(define (get-lock-db dbfile)
  (let* ((dbh (db:open-run-db dbfile db:initialize-db))
	 (res (db:get-iam-server-lock dbh dbfile)))
    (sqlite3:finalize! dbh)
    res))


(define *srvpktspec*
  `((server (host    . h)
	    (port    . p)
	    (servkey . k)
	    (pid     . i)
	    (ipaddr  . a)

				(let* ((all-pkts     (get-all-server-pkts pkts-dir *srvpktspec*))
				       (viables      (get-viable-servers all-pkts db-file))
				       (best-srv     (get-best-candidate viables db-file))
				       (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f)))
				  (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key)
				  ;; am I the best-srv, compare server-keys to know
				  (if (equal? best-srv-key server-key)
				      (if (get-lock-db sdat db-file) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id)
					  (debug:print 0 *default-log-port* "I'm the server!")
				      (if (get-lock-db db-file) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id)
					  (begin
					    (debug:print 0 *default-log-port* "I'm the server!")
					    (servdat-dbfile-set! sdat db-file))
					  (begin
					    (debug:print 0 *default-log-port* "I'm not the server, exiting.")
					    (bdat-time-to-exit-set! *bdat* #t)
					    (thread-sleep! 0.2)
					    (exit)))
				      (begin
					(debug:print 0 *default-log-port* "Keys do not match "best-srv-key", "server-key", exiting.")
					(bdat-time-to-exit-set! *bdat* #t)))
					(debug:print 0 *default-log-port*
						     "Keys do not match "best-srv-key", "server-key", exiting.")
					(bdat-time-to-exit-set! *bdat* #t)
					(thread-sleep! 0.2)
					(exit)))
				  sdat))
                              (begin
				(debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
                                (sleep 4)
				(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
				    (begin
				      (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")

	srfi-18
	srfi-69
	commonmod
	apimod
	itemsmod
	debugprint
	mtver
	regex
	tasksmod
	pgdb
	(prefix mtargs args:)
	dbmod
	http-transportmod
	servermod
	clientmod

    (if (and no-hurry (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
                              (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
			      (if *server-info*
				  (let ((pkt-file (conc (get-pkts-dir *toppath*)
							"/" (servdat-uuid *server-info*)
							".pkt")))
							".pkt"))
					(dbfile   (servdat-dbfile *server-info*)))
				    (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
				    (delete-file* pkt-file)))
			      (if (bdat-task-db *bdat*)    
				    (delete-file* pkt-file)
				    (if (and dbfile
					     (string-match ".*/main.db$" dbfile))
					(begin
					  (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
					  (with-lock-db (servdat-dbfile *server-info*)
							(lambda (dbh dbfile)
							  (db:release-lock dbh)))))))
			      (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)
					  ;; (vector-set! (bdat-task-db *bdat*) 0 #f)
					  (bdat-task-db-set! *bdat* #f)))))
                              (http-client#close-idle-connections!)
                              ;; (if (and *runremote*
                              ;;          (remote-conndat *runremote*))
                              ;;     (begin
                              ;;       (http-client#close-all-connections!))) ;; for http-client
                              (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