;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql
;;;
;; Copyright (C) 2007-2016 Matt Welland
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.
(use regex srfi-18 matchable)
(use (prefix ulex ulex:))
(use hostinfo)
(use shell)
(create-directory "ulexdb" #t)
(create-directory "pkts" #f)
(define *area* (ulex:make-area
dbdir: (conc (current-directory) "/ulexdb")
pktsdir: (conc (current-directory) "/pkts")
))
(define (toplevel-command . args) #f)
(use readline)
;; two reserved keys in the ulex registration hash table are:
;; dbinitsql => a list of sql statements to be executed at db creation time
;; dbinitfn => a function of two params; dbh, the sql-de-lite db handle and
;; dbfname, the database filename
;;
; totalmem usedmem sharedmem buffers cached adjbuffers adjcache totalswap usedswap freeswap
(ulex:register-batch
*area*
'dbwrite
`((dbinitsql . ("CREATE TABLE IF NOT EXISTS cpuload (id INTEGER PRIMARY KEY, timestamp INTEGER, hostname TEXT, proc INTEGER, core INTEGER, oneminload NUMERIC);"
" CREATE TABLE IF NOT EXISTS mem (id INTEGER PRIMARY KEY, timestamp INTEGER, hostname TEXT, totalmem INTEGER, usedmem INTEGER, sharedmem INTEGER, buffers INTEGER, cached INTEGER, adjbuffers INTEGER, adjcache INTEGER, totalswap INTEGER, usedswap INTEGER, freeswap INTEGER);"))
(savecpuload . "INSERT INTO cpuload (timestamp,hostname,proc,core,oneminload) VALUES (?,?,?,?,?)")
(savemem . "INSERT INTO mem (timestamp,hostname,totalmem,usedmem,sharedmem,buffers,cached,adjbuffers,adjcache,totalswap,usedswap,freeswap) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)")
))
(ulex:register-batch
*area*
'dbread
`((dbinitsql . ("CREATE TABLE IF NOT EXISTS cpuload (id INTEGER PRIMARY KEY, timestamp INTEGER, hostname TEXT, proc INTEGER, core INTEGER, oneminload NUMERIC);"
" CREATE TABLE IF NOT EXISTS mem (id INTEGER PRIMARY KEY, timestamp INTEGER, hostname TEXT, totalmem INTEGER, usedmem INTEGER, sharedmem INTEGER, buffers INTEGER, cached INTEGER, adjbuffers INTEGER, adjcache INTEGER, totalswap INTEGER, usedswap INTEGER, freeswap INTEGER);"))
(getnumcpuload . "SELECT COUNT(*) FROM cpuload")
(getsomecpuload . "SELECT * FROM cpuload LIMIT 10")
))
(define (worker mode-in)
(let* ((start (current-milliseconds))
(iters-per-sample 10)
(mode (string->symbol mode-in))
(max-count (case mode
((all) 60)
(else 1000)))
(num-calls 0)
(report (lambda ()
(let ((delta (- (current-milliseconds) start)))
(print "Completed " num-calls " in " delta
" for " (/ num-calls (/ delta 1000)) " calls per second")))))
(if (eq? mode 'repl)
(begin
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
(import (prefix ulex ulex:))
(install-history-file (get-environment-variable "HOME") ".example_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "example> "))
(repl))
(let loop ((count 0))
(case mode
((all)
(let* ((start-time (current-milliseconds))
(cpu-load-list (ulex:get-normalized-cpu-load-raw))
(num-proc (cdr(assoc 'proc cpu-load-list)))
(num-core (cdr(assoc 'core cpu-load-list)))
(one-min-load (cdr(assoc '1m-load cpu-load-list)))
(hostname (current-hostname))
(free-list (string-split (capture free)))
(totalmem (list-ref free-list 7))
(usedmem (list-ref free-list 8))
(sharedmem (list-ref free-list 9))
(buffers (list-ref free-list 10))
(cached (list-ref free-list 11))
(adjbuffers (list-ref free-list 15))
(adjcache (list-ref free-list 16))
(totalswap (list-ref free-list 18))
(usedswap (list-ref free-list 19))
(freeswap (list-ref free-list 20))
)
(ulex:call *area* "cpu_load.db" 'savecpuload (list start-time hostname num-proc num-core one-min-load))
(ulex:call *area* "mem.db" 'savemem (list start-time hostname totalmem usedmem sharedmem buffers cached adjbuffers adjcache totalswap usedswap freeswap))
(set! num-calls (+ num-calls 1))
(thread-sleep! 5)
)
)
)
(if (< count max-count)
(loop (+ count 1)))))
(report)
(ulex:clear-server-pkt *area*)
(thread-sleep! 5) ;; let others keep using this server (needs to be built in to ulex)
(print "Done doing stuff")))
(define (run-worker)
(thread-start!
(make-thread (lambda ()
(thread-sleep! 5)
(worker "all"))
"worker")))
(define (main . args)
(if (member (car args) '("repl"))
(print "NOTE: No exit timer started.")
(thread-start! (make-thread (lambda ()
(thread-sleep! (* 60 5))
(ulex:clear-server-pkt *area*)
(thread-sleep! 5)
(exit 0)))))
(print "Launching server")
(ulex:launch *area*)
(print "LAUNCHED.")
(thread-sleep! 0.1) ;; chicken threads bit quirky? need little time for launch thread to get traction?
(apply worker args)
)
;;======================================================================
;; Strive for clean exit handling
;;======================================================================
;; Ulex shutdown is handled within Ulex itself.
#;(define (server-exit-procedure)
(on-exit (lambda ()
;; close the databases, ensure the pkt is removed!
;; (thread-sleep! 2)
(ulex:shutdown *area*)
0)))
;; Copied from the SDL2 examples.
;;
;; Schedule quit! to be automatically called when your program exits normally.
#;(on-exit server-exit-procedure)
;; Install a custom exception handler that will call quit! and then
;; call the original exception handler. This ensures that quit! will
;; be called even if an unhandled exception reaches the top level.
#;(current-exception-handler
(let ((original-handler (current-exception-handler)))
(lambda (exception)
(server-exit-procedure)
(original-handler exception))))
(if (file-exists? ".examplerc")
(load ".examplerc"))
(let ((args-in (argv))) ;; command-line-arguments)))
(let ((args (match
args-in
(("csi" "--" args ...) args)
((_ args ...) args)
(else args-in))))
(if (null? args)
(begin
(print "Usage: example [mode]")
(print " where mode is one of:")
(print " all : do cpu and mem stat writes")
(exit))
(apply main args))))