;;======================================================================
;; P O R T L O G G E R - track ports used on the current machine
;;======================================================================
;;
(module portlogger
(pl-open-run-close pl-find-port pl-release-port pl-open-db pl-get-prev-used-port pl-get-port-state pl-take-port)
(import scheme
posix
chicken
data-structures
;ports
extras
;files
;mailbox
;telemetry
regex
;regex-case
)
(use (prefix sqlite3 sqlite3:))
(use posix)
(use regex)
(define (pl-open-db fname)
(let* ((avail #t) ;; for now - assume wait on journal not needed (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
(exists (file-exists? fname))
(db (if avail
(sqlite3:open-database fname)
(begin
(system (conc "rm -f " fname))
(sqlite3:open-database fname))))
(handler (sqlite3:make-busy-timeout 136000))
(canwrite (file-write-access? fname)))
(sqlite3:set-busy-handler! db handler)
(sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute
db
"CREATE TABLE IF NOT EXISTS ports (
port INTEGER PRIMARY KEY,
state TEXT DEFAULT 'not-used',
fail_count INTEGER DEFAULT 0,
update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
db))
(define (pl-open-run-close proc . params)
(let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db"))
(avail #t)) ;; (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
;; (handle-exceptions
;; exn
;; (begin
;; ;; (release-dot-lock fname)
;; (debug:print-error 0 *default-log-port* "pl-open-run-close failed. " proc " " params)
;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (debug:print 5 *default-log-port* "exn=" (condition->list exn))
;; (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it
;; (print-call-chain (current-error-port)))
(let* (;; (lock (obtain-dot-lock fname 2 9 10))
(db (pl-open-db fname))
(res (apply proc db params)))
(sqlite3:finalize! db)
;; (release-dot-lock fname)
res)))
;; )
;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
(define (pl-take-port db portnum)
(let* ((qry1 "INSERT INTO ports (port,state) VALUES (?,?);")
(qry2 "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;"))
(let* ((curr (pl-get-port-state db portnum))
(res (case (string->symbol (or curr "n/a"))
((released) (sqlite3:execute db qry2 "taken" portnum) 'taken)
((not-tried n/a) (sqlite3:execute db qry1 portnum "taken") 'taken)
((taken) 'already-taken)
((failed) 'failed)
(else 'error))))
;; (print "res=" res)
res)))
(define (pl-get-prev-used-port db)
;; (handle-exceptions
;; exn
;; (with-output-to-port (current-error-port)
;; (lambda ()
;; (print "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
;; (print " message: " ((condition-property-accessor 'exn 'message) exn))
;; (print "exn=" (condition->list exn))
;; (print-call-chain) ;; (current-error-port))
;; (print "Continuing anyway.")
;; #f))
(let ((res (sqlite3:fold-row
(lambda (var curr)
(or curr var curr))
#f
db "SELECT port FROM ports WHERE state='released';")))
(if res res #f)))
;; )
(define (pl-find-port db acfg #!key (lowport 32768))
;;(slite3:with-transaction
;; db
;; (lambda ()
(let loop ((numtries 0))
(let* ((portnum (or (pl-get-prev-used-port db)
(+ lowport ;; top of registered ports is 49152 but let's use ports in the registered range
(random (- 64000 lowport))))))
;; (handle-exceptions
;; exn
;; (with-output-to-port (current-error-port)
;; (lambda ()
;; (print "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
;; (print " message: " ((condition-property-accessor 'exn 'message) exn))
;; (print "exn=" (condition->list exn))
;; (print-call-chain)
;; (print "Continuing anyway.")))
(pl-take-port db portnum) ;; always "take the port"
(if (pl-is-port-available portnum)
portnum
(begin
(pl-set-port db portnum "taken")
(loop (add1 numtries)))))))
;; set port to "released", "failed" etc.
;;
(define (pl-set-port db portnum value)
(sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;") value portnum)
;; set port to "released", "failed" etc.
;;
(define (pl-get-port-state db portnum)
(let ((res (sqlite3:fold-row ;; get the state of given port or "not-tried"
(lambda (var curr) ;; function on init/last current
(or curr var curr))
#f ;; init
db "SELECT state FROM ports WHERE port=?;"
portnum))) ;; the parameter to the query
(if res res #f)))
;; (slite3:exec (slite3:sql db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;") value portnum))
;; release port
(define (pl-release-port db portnum)
(sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" "released" portnum)
(sqlite3:change-count db))
;; set port to failed (attempted to take but got error)
;;
(define (pl-set-failed db portnum)
(sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum)
(sqlite3:change-count db))
;; pulled from mtut - TODO: remove from mtut, find a way *without* using netstat
;;
(define (pl-is-port-available port-num)
(let-values (((inp oup pid)
(process "netstat" (list "-tulpn" ))))
(let loop ((inl (read-line inp)))
(if (not (eof-object? inl))
(begin
(if (string-search (regexp (conc ":" port-num "\\s+")) inl)
#f
(loop (read-line inp))))
#t))))
) ;; end module