;;; 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)
(load "ulex.scm")
(import (prefix ulex ulex:))
(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
;;
(ulex:register-batch
*area*
'dbwrite
`((dbinitsql . ("CREATE TABLE IF NOT EXISTS messages (id INTEGER PRIMARY KEY, message TEXT, author TEXT, msg_time INTEGER);"))
(savemsg . "INSERT INTO messages (message,author) VALUES (?,?)")
))
(ulex:register-batch
*area*
'dbread
`((dbinitsql . ("CREATE TABLE IF NOT EXISTS messages (id INTEGER PRIMARY KEY, message TEXT, author TEXT, msg_time INTEGER);"))
(getnum . "SELECT COUNT(*) FROM messages")
(getsome . "SELECT * FROM messages 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))
;; (print "loop count=" count)
(for-each
(lambda (dbname)
;;(print "TOP OF LAMBDA")
(case mode
((all)
(let ((start-time (current-milliseconds))
(message (conc "Test message #" count "! From pid: " (current-process-id)))
(user (current-user-name)))
(ulex:call *area* dbname 'savemsg `(,message ,user))
(for-each (lambda (n)
(print "have this many " (ulex:call *area* dbname 'getnum '()) " records in main.db"))
(iota 10))
(set! num-calls (+ num-calls 11))
))
((ping)
(let ((srvrs (ulex:get-all-server-pkts *area*)))
(for-each
(lambda (srv)
(print "Pinging " srv)
(ulex:ping *area* srv))
srvrs)))
((fullping)
(let ((srvrs (ulex:get-all-server-pkts *area*)))
(for-each
(lambda (srv)
(let ((ipaddr (alist-ref 'ipaddr srv))
(port (any->number (alist-ref 'port srv))))
(print "Full Ping to " srv)
(ulex:ping *area* ipaddr port)))
srvrs)))
((passive)
(thread-sleep! 10))
))
'("main.db")) ;; "test.db" "run-1.db" "run-2.db" "run-3.db" "run-4.db"))
#;(thread-sleep! 0.001)
#;(let ((now (current-milliseconds)))
(if (and (> now start)
(eq? (modulo count iters-per-sample) 0))
(begin
(print "queries per second: "(* 1000.0 (/ iters-per-sample (- now start))))
(set! count 0)
(set! start (current-milliseconds)))))
;; (print "count: " count " max-count: " max-count)
(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 "Doing stuff")
;; (thread-sleep! 10)
(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 " ping : only do pings between servers")
(print " fullping : ping with response via processing queue")
(print " unix : only do unix commands")
(print " read : only do ping, unix and db reads")
(print " all : do pint, unix, and db reads and writes")
(exit))
(apply main args))))