pgcharts/ 0000755 0001750 0001750 00000000000 12572064366 012572 5 ustar vagrant vagrant pgcharts/src/ 0000755 0001750 0001750 00000000000 12572256023 013352 5 ustar vagrant vagrant pgcharts/src/front-notebook.lisp 0000644 0001750 0001750 00000000740 12416477476 017230 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Frontend for editing a notebook, thanks to Hallo
;;;
(defun front-new-notebook ()
"Return the basic HTML for a new notebook"
(serve-page
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:div :class "editable" :contenteditable "true"
(:h1 "Your new SQL Notebook title")
(:p "Edit your text here, whatever you want")))))))
pgcharts/src/front-main.lisp 0000644 0001750 0001750 00000005326 12375612734 016331 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Main dashboard
;;;
(defun list-queries (query-list &key (title "Queries"))
"Return a whole web page for the QUERY-LIST."
(serve-page
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:h1 :class "page-header" (str title))
(:h4 :style "color: red;" "Warning "
(:small "The delete action requires no validation."))
(:div :class "table-responsive"
(:table :class "table table-stripped"
(:thead
(:tr (:th "")
(:th "Query")
(:th "Database")
(:th "Description")
(:th "Chart")))
(:tbody
(loop :for query :in query-list
:do (htm
(:tr
(:td
(:a :href (q/url query)
(:span :class "glyphicon glyphicon-edit"
:style "color: black;"))
" "
(:a :href (q/del/url query)
(:span :class "glyphicon glyphicon-remove"
:style "color: red;")))
(:td (:a :href (q/url query)
(str (format nil "~36r" (qid query)))))
(:td (str (dbname query)))
(:td (:a :href (q/url query)
(str (qdesc query))))
(:td (:a :href (c/url query)
(:span :class "glyphicon glyphicon-stats"
" "
(str (chart-type query))))))))))))))))
(defun front-list-queries ()
"Serve the list of SQL queries."
(list-queries (with-pgsql-connection (*dburi*)
(select-dao 'query t 'db 'qname))))
(defun front-search-queries ()
"Return a list of queries loosely matching given TERMS."
(let ((terms (hunchentoot:get-parameter "terms")))
(list-queries (with-pgsql-connection (*dburi*)
(select-dao 'query (:or (:~* 'description terms)
(:~* 'sql terms))))
:title (format nil "Queries matching regexp: ~a" terms))))
pgcharts/src/front-raw-query.lisp 0000644 0001750 0001750 00000013314 12400064115 017314 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Raw query allows to easily play around with a SQL query without having
;;; to actually prepare and setup all the Charting jazz.
;;;
(defun front-raw-query (&optional qid)
"Return the HTML to display a query form."
(destructuring-bind (&key q ((:d dbname-list)))
(let ((dbname (hunchentoot:post-parameter "dbname"))
(qname (hunchentoot:post-parameter "qname"))
(qdesc (hunchentoot:post-parameter "qdesc"))
(query (hunchentoot:post-parameter "query")))
(with-pgsql-connection (*dburi*)
(list :q (if qid
(get-dao 'query (parse-integer qid :radix 36))
(make-instance 'query
:dbname dbname
:qname qname
:description qdesc
:sql query
:cats ""
:series ""
:xtitle ""
:ytitle ""
:chart-type ""))
:d (query "select dbname from db order by 1" :column))))
(serve-page
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:h1 :class "page-header" "SQL Query")
(:form :role "query"
:id "run-query"
:method "post"
:action "/q/raw"
:class "form-horizontal"
(:input :type "hidden" :id "qid" :name "qid" :value qid)
(:input :type "hidden"
:id "chart-type" :name "chart-type" :value "raw")
(:div :class "form-group"
(:label :for "dbname" :class "col-sm-3 control-label"
"Database name")
(:div :class "col-sm-9"
(:select :id "dbname"
:name "dbname"
:class "form-control"
(loop :for dbname :in dbname-list
:do (htm (:option (str dbname)))))))
(:div :class "form-group"
(:label :for "qname" :class "col-sm-3 control-label"
"Query name")
(:div :class "col-sm-9"
(:input :type "text" :name "qname" :id "qname"
:placeholder "Enter query name"
:class "form-control"
:value (qname q))))
(:div :class "form-group"
(:label :for "qdesc" :class "col-sm-3 control-label"
"Query description")
(:div :class "col-sm-9"
(:input :type "text" :name "qdesc" :id "qdesc"
:placeholder "Enter query description"
:class "form-control"
:value (qdesc q))))
(:div :class "form-group"
(:label :for "query" :class "col-sm-3 control-label"
"Query SQL")
(:div :class "col-sm-9"
(:textarea :id "query" :name "query" :rows "25"
(str (qsql q)))))
(:div :class "form-group"
(:div :class "col-sm-offset-3 col-sm-2"
(:button :id "btn-run-raw-query"
:class "btn btn-success"
:type "submit" "Run Query"))
(:div :class "col-sm-offset-5 col-sm-2"
(:button :id "btn-save-raw-query"
:class "btn btn-primary"
:type "button" "Save Query"))))
(:script "
var myCodeMirror = CodeMirror.fromTextArea(query, {
lineWrapping: true,
lineNumbers: true,
styleActiveLine: true,
matchBrackets: true,
mode: \"text/x-plsql\",
theme: \"elegant\"
});"))
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:h1 :class "page-header" "Result Set")
(:div :id "qresult" :class "table-responsive"
(when (and (qsql q) (not (string= "" (qsql q))))
(str (front-raw-result (dbname q) (qsql q)))))))))))
(defun front-raw-result (dbname query)
"Return the HTML string for the result of given query."
(let* ((qdburi (with-pgsql-connection (*dburi*)
(db-uri (get-dao 'db dbname))))
(data (with-pgsql-connection (qdburi)
(query query :alists))))
(with-html-output-to-string (s)
(:table :class "table table-stripped table-hover table-condensed"
(:thead
(:tr (loop :for (col . val) :in (first data)
:do (htm (:th (str col))))))
(:tbody
(loop :for row :in data
:do (htm
(:tr
(loop :for (col . val) :in row
:do (htm (:td (str val))))))))))))
pgcharts/src/image.lisp 0000644 0001750 0001750 00000000173 12375734143 015333 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Special code to execute when preparing the binary image.
;;;
(setf *serve-from-cache* t)
pgcharts/src/front-tools.lisp 0000644 0001750 0001750 00000006120 12375615134 016533 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; General tools to render frontend code
;;;
(defun compute-menu (current-url-path)
"List all files found in the *DOCROOT* directory and turns the listing
into a proper bootstrap menu."
(when *dburi*
;; all the entries in the menu only work properly with a database
;; connection (that has been setup), so refrain from displaying them
;; when the basic setup has not been done yet.
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-3 col-md-2 sidebar"
(:ul :class "nav nav-sidebar"
(:li :class (when (string= current-url-path "/") "active")
(:a :href "/" (:span :class "glyphicon glyphicon-filter"
" "
(str "Queries"))))
(:li :class (when (string= current-url-path "/q/raw") "active")
(:a :href "/q/raw" (:span :class "glyphicon glyphicon-pencil"
" "
(str "New Query")) ))
(:li :class (when (string= current-url-path "/q/new") "active")
(:a :href "/q/new" (:span :class "glyphicon glyphicon-tasks"
" "
(str "New Chart")) ))
(:hr)
(loop :for db
:in (with-pgsql-connection (*dburi*)
(select-dao 'db t 'dbname))
:for active := (string= (dbname db) current-url-path)
:do (htm
(:li :class (when active "active")
(:a :href (format nil "/d/~a" (dbname db))
(:span :class "glyphicon glyphicon-folder-open")
" "
(str (dbname db))))))))))))
(defmacro serve-page (content)
"Return the content with header and footer and menu, and handle errors."
`(concatenate 'string
(serve-header)
(compute-menu "/#q")
(handler-case
,content
(condition (e)
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:h2 :class "page-header"
(:span :class "glyphicon glyphicon-eye-close"
" Unexpected condition"))
(:h4 :style "color: red; text-weight: bold;"
(str (format nil "~a" e)))
(:pre
(str
(trivial-backtrace:print-backtrace e
:output nil
:verbose t))))))))
(serve-footer)))
pgcharts/src/sql/ 0000755 0001750 0001750 00000000000 12377642536 014164 5 ustar vagrant vagrant pgcharts/src/sql/20140823--20140828.sql 0000644 0001750 0001750 00000002322 12377642536 016572 0 ustar vagrant vagrant ---
--- Upgrade database model from version 20140823 to version 20140828
---
create table pgcharts.catalog
(
version text primary key
);
create table pgcharts.new_db
(
dbname text primary key,
dburi text
);
insert into pgcharts.new_db
select dbname, 'pgsql://'
|| coalesce(dbuser, '')
|| case when dbpass is not null and dbpass <> 'false'
then ':' || dbpass
else ''
end
|| case when dbhost is not null
then case when dbuser is not null
then '@' || dbhost
else dbhost
end
else ''
end
|| case when dbport is not null
then ':' || dbport
else ''
end
|| '/'
|| dbname
from pgcharts.db;
alter table pgcharts.db rename to old_db;
alter table pgcharts.new_db rename to db;
insert into pgcharts.catalog(version) values('20140828');
pgcharts/src/sql/model-update.lisp 0000644 0001750 0001750 00000003106 12377635627 017440 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; To automate pgcharts model updates, we model a system after the
;;; PostgreSQL extension update mecanism.
;;;
;;; This is an implementation of Dijkstra's algorithm to find the shortest
;;; path copied from the PostgreSQL's source code (in C).
;;;
(defparameter *upgrade-scripts*
(mapcar
(lambda (pathname)
(cons (pathname-name pathname) (read-queries pathname)))
(remove-if-not (lambda (pathname)
(and (pathname-type pathname)
(string= "sql" (pathname-type pathname))))
(uiop:directory-files
(asdf:system-relative-pathname :pgcharts "src/sql/"))))
"List of SQL upgrade scripts, each one being and alist of its pathname as
the key and the script itself as the value." )
(defun pathname-to-versions (upgrade-script)
"Given a PATHNAME, return source and target version of the script."
(mapcar #'parse-integer (cl-ppcre:split "--" (car upgrade-script))))
(defun versions-to-pathname (versions)
"Given a list of versions, returns the SQL script pathname."
(format nil "~{~a~^--~}" versions))
(defun find-update-path (old-version new-version)
"Pick an upgrade path given the list of available update scripts."
(let* ((graph (make-instance 'graph:graph))
(edges (mapcar #'pathname-to-versions *upgrade-scripts*)))
(graph:populate graph :edges edges)
(mapcar #'versions-to-pathname
(graph:shortest-path graph
(parse-integer old-version)
(parse-integer new-version)))))
pgcharts/src/pgcharts.lisp 0000644 0001750 0001750 00000014444 12543560147 016070 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Handle the command line interface
;;;
(defvar *version-string* "1.0"
"Version string: X.0 are development versions.")
(defvar *options*
(list (make-option :help "-h" "--help")
(make-option :version "-V" "--version")
(make-option :config "-c" "--config" #'set-config-filename t))
"List of allowed options for the main pgcharts command line.")
(define-condition server-error ()
((uri :initarg :uri :reader server-error-uri)
(status-code :initarg :status :reader server-error-status-code)
(reason :initarg :reason :reader server-error-reason)
(body :initarg :body :reader server-error-body)))
(define-condition cli-error ()
((mesg :initarg :mesg :initform nil :reader cli-error-message)
(detail :initarg :detail :initform nil :reader cli-error-detail)
(hint :initarg :hint :initform nil :reader cli-error-hint)))
(defun main (argv)
"The main entry point for the command-line interface."
(multiple-value-bind (args opts)
(process-argv-options argv)
(when (member :help opts)
(usage args :help t)
(uiop:quit 0))
(when (member :version opts)
(format t "pgcharts version ~s~%" *version-string*)
(format t "compiled with ~a ~a~%"
(lisp-implementation-type)
(lisp-implementation-version))
(uiop:quit 0))
;; don't do anything when --help or --version were given
(let ((match (find-command-function args)))
(if match
(destructuring-bind (fun args) match
(handler-case
(handler-bind ((warning
#'(lambda (c)
(format t "WARNING: ~a~%" c)
(muffle-warning))))
(apply fun args))
(cli-error (e)
(format t
"ERROR: ~a~%~@[DETAIL: ~a~%~]~@[HINT: ~a~%~]"
(cli-error-message e)
(cli-error-detail e)
(cli-error-hint e)))
(server-error (e)
(format t
"ERROR ~d ON ~a~%~@[REASON: ~a~%~]~@[BODY: ~a~%~]"
(server-error-status-code e)
(server-error-uri e)
(server-error-reason e)
(server-error-body e)))
(condition (c)
(if (member :debug opts)
(invoke-debugger c)
(format t "ERROR: ~a~%" c)))))
(usage argv)))))
;;;
;;; Actual commands
;;;
(define-command (("setup") (&optional dburi))
"setup the pgcharts database"
(let ((*dburi* (or dburi *dburi*)))
(write-config)
(ensure-model-is-current)))
(define-command (("status") ())
"get the status of the currently running server"
(handler-case
(format t "~a~%" (server-status))
(condition (e)
(error 'cli-error
:mesg "pgcharts is not running"
:detail (format nil "~a" e)))))
(define-command (("pid") ())
"prints the PID of the server, if running"
(format t "~a~%" (read-pid *pidfile*)))
(define-command (("stop") ())
"stop the pgcharts web server"
(kill-server))
(define-command (("start") ())
"start the pgcharts web server"
(check-setup)
(let ((status (ignore-errors (server-status))))
(unless (and status (string= "OK" status))
(daemon:daemonize :output *logfile*
:error *logfile*
:pidfile *pidfile*
:exit-parent t
:sigterm (lambda (sig)
(declare (ignore sig))
(stop-server)))
(start-server :logs *logfile*)
(loop :while *server-is-running*
:do (sleep 1)))))
(define-command (("register") (dburi))
"register a database"
(register-db dburi))
(define-command (("config") ())
"print current config"
(format t "Current config file: ~s~%" *config-filename*)
(with-open-file (config *config-filename*)
(uiop:copy-stream-to-stream config *standard-output*)))
(define-command (("get") (key))
"display current value for given configuration key"
(print-config-value key))
(define-command (("set") (key &optional val))
"edit configuration variables"
(if val
(setf (config-value key) val)
(print-config-value key)))
;;;
;;; Support code for the previous commands
;;;
(defun print-config-value (key)
"Print the value for KEY, print nothing in error cases."
(let ((value (config-value key)))
(when value
(format t "~a~%" value))))
(defun server-status ()
"Get the server status over HTTP."
(multiple-value-bind (body status-code headers uri stream must-close reason)
(drakma:http-request (format nil "http://localhost:~d/status" *listen-port*))
(declare (ignore headers stream must-close))
(if (= status-code 200)
body
(error 'server-error
:uri uri :status status-code :reason reason :body body))))
(defun kill-server (&optional (sig "TERM"))
"Send a signal to the server for it to stop"
(when (kill-pid (read-pid *pidfile*) sig)
(ignore-errors (delete-file *pidfile*))))
(defun register-db (dburi)
"Register a new database server."
(when (validate-dburi dburi)
(destructuring-bind (name &rest rest)
(parse-pgsql-connection-string dburi)
(declare (ignore rest))
(with-pgsql-connection (*dburi*)
(make-dao 'db :dbname name :dburi dburi)))))
(defun check-setup ()
"Signal a condition when the setup isn't ready for starting the service."
(unless *dburi*
(error 'cli-error
:mesg "dburi is unset"
:detail "pgcharts need its own database"
:hint "run: pgcharts setup pgsql://user:pass@host/dbname"))
(handler-case
(validate-dburi *dburi*)
(condition (e)
(error 'cli-error
:mesg (format nil "~a" e)
:detail (format nil "failed to connect to dburi ~s" *dburi*)
:hint (format nil "~a~%~a~%"
"createdb dbname; then set dburi:"
"run: pgcharts setup pgsql://user:pass@host/dbname"))))
;; If necessary, do the initial setup, or maybe upgrade the database
(ensure-model-is-current *dburi*))
pgcharts/src/front-db.lisp 0000644 0001750 0001750 00000003422 12375603742 015764 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Database objects browser.
;;;
(defun front-browse-database (dbname)
"Not Yet Implemented"
(let* ((qdburi (with-pgsql-connection (*dburi*)
(db-uri (get-dao 'db dbname))))
(table-list (with-pgsql-connection (qdburi)
(query "
select nspname, relname, relkind,
string_agg(a.attname, ', ' order by a.attnum) as cols
from pg_class c
join pg_namespace n on n.oid = c.relnamespace
left join pg_attribute a on a.attrelid = c.oid and attnum > 0
where n.nspname not in ('pg_catalog', 'information_schema')
and relkind in ('r', 'v')
and has_table_privilege(c.oid, 'SELECT')
and pg_table_is_visible(c.oid)
group by nspname, relname, relkind
order by nspname, relname" :rows))))
(serve-page
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:h2 :class "page-header" (str dbname))
(:div :class "table-responsive"
(:table :class "table table-stripped table-hover"
(:thead
(:tr (:th "Schema")
(:th "Table name")
(:th "Columns")))
(:tbody
(loop :for (nspname relname relkind cols) :in table-list
:do (htm
(:tr
(:td (str nspname))
(:td (str relname))
(:td (str cols))))))))))))))
pgcharts/src/config.lisp 0000644 0001750 0001750 00000017077 12572043730 015523 0 ustar vagrant vagrant (in-package #:pgcharts)
(defvar *config-filename* "~/.pgcharts.ini"
"Where to store pgcharts configuration.")
(defparameter *dburi* nil
"PostgreSQL database connection.")
(defparameter *listen-address* nil
"Which address to listen to, defaults to nil, meaning *.")
(defparameter *listen-port* 9042
"Port bound by the repository server, exposing the HTTP protocol.")
(defparameter *pidfile* "~/.pgcharts.pid"
"pgcharts pid file")
(defparameter *logfile* "/tmp/pgcharts.log"
"Main logfile for pgcharts")
(defparameter *document-root*
(asdf:system-relative-pathname :pgcharts "web/"))
(defparameter *js-root*
(asdf:system-relative-pathname :pgcharts "web/js"))
(defparameter *bootstrap-root*
(asdf:system-relative-pathname :pgcharts "web/bootstrap-3.1.1-dist"))
(defparameter *images-root*
(asdf:system-relative-pathname :pgcharts "web/images"))
(defparameter *highcharts-root*
(asdf:system-relative-pathname :pgcharts "web/highcharts"))
(defparameter *codemirror-root*
(asdf:system-relative-pathname :pgcharts "web/codemirror-4.5"))
(defparameter *d3js*
(asdf:system-relative-pathname :pgcharts "web/d3js/d3.min.js"))
(defparameter *hallo-root*
(asdf:system-relative-pathname :pgcharts "web/hallo"))
(defparameter *fontawesome-root*
(asdf:system-relative-pathname :pgcharts "web/font-awesome-4.2.0"))
(defparameter *header-path*
(asdf:system-relative-pathname :pgcharts "web/header.html"))
(defparameter *footer-path*
(asdf:system-relative-pathname :pgcharts "web/footer.html"))
(defvar *serve-from-cache* nil
"Set to t to serve static resources from in-memory cache.")
;;;
;;; System integration: configuration file.
;;;
(defun expand-user-homedir-pathname (namestring)
"Expand NAMESTRING replacing leading ~ with (user-homedir-pathname)"
(typecase namestring
(pathname namestring)
(string
(cond ((or (string= "~" namestring) (string= "~/" namestring))
(user-homedir-pathname))
((and (<= 2 (length namestring))
(char= #\~ (aref namestring 0))
(char= #\/ (aref namestring 1)))
(uiop:merge-pathnames*
(uiop:parse-unix-namestring (subseq namestring 2))
(user-homedir-pathname)))
(t
(uiop:parse-unix-namestring namestring))))))
(defun set-config-filename (namestring)
(setf *config-filename* (expand-user-homedir-pathname namestring)))
;;;
;;; Defaults, organized in sections, with proper use facing option names
;;;
(defvar *sections-variables*
'(("pgcharts"
("dburi" *dburi*)
("port" *listen-port* parse-integer)
("address" *listen-address* parse-listen-address)
("pidfile" *pidfile* check-file-path)
("logfile" *logfile* check-file-path))))
;;;
;;; Turn CL list of lists into INI files and back, and also take care of
;;; changing the dynamic variables values.
;;;
(defun read-config (&optional (filename *config-filename*))
"Read the FILENAME INI file and set the special variables accordingly."
(when (probe-file filename)
(let* ((ini (ini:make-config))
(conf (ini:read-files ini (list filename))))
(loop :for (section . options) :in *sections-variables*
:do (loop :for (option var check-fun) :in options
:when (ini:has-option-p conf section option)
:do (let ((value (ini:get-option conf section option)))
(setf (symbol-value var)
(if check-fun
(handler-case
(funcall check-fun value)
;; allow reading broken config
(condition (c)
(warn "Validation function ~s failed on ~s: ~a"
check-fun
value
c)
value))
;; no check, just use value
value)))))
conf)))
(defun write-current-config (stream)
"Write the current configuration of pginstall in STREAM."
(let ((config (ini:make-config)))
(loop for (section . options) in *sections-variables*
do (progn
(ini:add-section config section)
(loop for (option var check-fun) in options
do (ini:set-option config section option (symbol-value var)))))
(ini:write-stream config stream)
config))
(defun save-config (&optional (pathname
(expand-user-homedir-pathname *config-filename*)))
"Save the current configuration of pginstall in FILENAME."
(with-open-file (s pathname
:direction :output
:if-exists :supersede
:if-does-not-exist :create
:external-format :utf8)
(write-current-config s)))
(defun config-value (option-name)
"Get the current value of the given OPTION-NAME."
(loop :for (section . options) :in *sections-variables*
:for value := (loop :for (option var check-fun) :in options
:when (string-equal option-name option)
:return (symbol-value var))
:when value
:return value))
(defun (setf config-value) (newvalue option-name)
"Set configuration variable OPTION-NAME to NEWVALUE."
(loop :for (section . options) :in *sections-variables*
:do (loop for (option var check-fun) :in options
:when (string-equal option-name option)
:do (progn
(funcall check-fun newvalue)
(setf (symbol-value var) newvalue)))))
;;;
;;; pidfile reading
;;;
(defun read-pid (&optional (pidfile *pidfile*))
"Read the server's pid from *pidfile* and return it as a string."
(with-open-file (s pidfile) (read-line s)))
(defun kill-pid (pid &optional (sig "TERM"))
"Send given SIG to Unix process PID."
(multiple-value-bind (output error code)
(uiop:run-program `("/bin/kill" ,(format nil "-~a" sig) ,pid)
:output :string
:error :string
:ignore-error-status t)
(declare (ignore output error))
(= 0 code)))
;;
;; Validation functions
;;
(defun check-and-make-directory (value)
"Check that VALUE is a valid pathname and create a directory if it doesn't
already exists."
(ensure-directories-exist
(uiop:ensure-directory-pathname (expand-user-homedir-pathname value))))
(defun check-executable (value)
"Check that VALUE is the pathname of a valid executable file."
value)
(defun check-file-path (path)
"Check that we can open a file at given PATH."
(let ((expanded-path (expand-user-homedir-pathname path)))
(ensure-directories-exist (directory-namestring expanded-path))
;; then return expanded path
expanded-path))
(defun check-log-setting (log-threshold &optional (default :notice))
"Read a log threshold setting from CLI or INI file"
(let ((threshold (find-symbol (string-upcase log-threshold) "KEYWORD")))
(if (member threshold '(:panic :fatal :log :error :warning
:notice :info :debug :data))
threshold
(progn
(warn "Didn't recognize log threshold ~s, using ~s instead."
log-threshold (symbol-name default))
default))))
(defun parse-listen-address (listen-address)
"Change * into nil. Don't try to double-guess hunchentoot on what is a
proper CNAME or IP address (ipv6 etc)."
(if (or (string-equal "NIL" listen-address)
(string= "*" listen-address))
nil
listen-address))
pgcharts/src/utils/ 0000755 0001750 0001750 00000000000 12461222102 014476 5 ustar vagrant vagrant pgcharts/src/utils/dburi.lisp 0000644 0001750 0001750 00000013307 12461222102 016500 0 ustar vagrant vagrant ;;;
;;; Parse database connection string
;;;
(in-package #:pgcharts.dburi)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun getenv-default (name &optional default)
"Return the value of the NAME variable as found in the environment, or
DEFAULT if that variable isn't set"
(or (uiop:getenv name) default)))
(defrule punct (or #\, #\- #\_)
(:text t))
(defrule namestring (* (or (alpha-char-p character)
(digit-char-p character)
punct))
(:text t))
(defrule dsn-port (and ":" (* (digit-char-p character)))
(:destructure (colon digits &aux (port (coerce digits 'string)))
(declare (ignore colon))
(list :port (if (null digits) digits
(parse-integer port)))))
(defrule doubled-at-sign (and "@@") (:constant "@"))
(defrule doubled-colon (and "::") (:constant ":"))
(defrule password (+ (or (not "@") doubled-at-sign)) (:text t))
(defrule username (+ (or (not (or ":" "@")) doubled-at-sign doubled-colon))
(:text t))
(defrule dsn-user-password (and username
(? (and ":" (? password)))
"@")
(:lambda (args)
(destructuring-bind (username &optional password)
(butlast args)
;; password looks like '(":" "password")
(list :user username :password (cadr password)))))
(defun hexdigit-char-p (character)
(member character #. (quote (coerce "0123456789abcdefABCDEF" 'list))))
(defrule ipv4-part (and (digit-char-p character)
(? (digit-char-p character))
(? (digit-char-p character))))
(defrule ipv4 (and ipv4-part "." ipv4-part "." ipv4-part "." ipv4-part)
(:lambda (ipv4)
(list :ipv4 (text ipv4))))
;;; socket directory is unix only, so we can forbid ":" on the parsing
(defun socket-directory-character-p (char)
(or (member char #.(quote (coerce "/.-_" 'list)))
(alphanumericp char)))
(defrule socket-directory (and "unix:" (* (socket-directory-character-p character)))
(:destructure (unix socket-directory)
(declare (ignore unix))
(list :unix (when socket-directory (text socket-directory)))))
(defrule network-name (and namestring (* (and "." namestring)))
(:lambda (name)
(let ((host (text name)))
(list :host (unless (string= "" host) host)))))
(defrule hostname (or ipv4 socket-directory network-name)
(:identity t))
(defrule dsn-hostname (and (? hostname) (? dsn-port))
(:destructure (hostname &optional port)
(append (list :host hostname) port)))
(defrule dsn-dbname (and "/" (? namestring))
(:destructure (slash dbname)
(declare (ignore slash))
(list :dbname dbname)))
(defrule dsn-option-ssl-disable "disable" (:constant :no))
(defrule dsn-option-ssl-allow "allow" (:constant :try))
(defrule dsn-option-ssl-prefer "prefer" (:constant :try))
(defrule dsn-option-ssl-require "require" (:constant :yes))
(defrule dsn-option-ssl (and "sslmode" "=" (or dsn-option-ssl-disable
dsn-option-ssl-allow
dsn-option-ssl-prefer
dsn-option-ssl-require))
(:lambda (ssl)
(destructuring-bind (key e val) ssl
(declare (ignore key e))
(cons :use-ssl val))))
(defrule dsn-option (or dsn-option-ssl))
(defrule dsn-options (and "?" (* dsn-option))
(:lambda (options)
(destructuring-bind (qm opts) options
(declare (ignore qm))
(alexandria:alist-plist opts))))
(defrule dsn-prefix (or "pgsql://" "postgresql://") (:constant nil))
(defrule db-connection-uri (and dsn-prefix
(? dsn-user-password)
(? dsn-hostname)
dsn-dbname
(? dsn-options))
(:lambda (uri)
(destructuring-bind (&key type
user
password
host
port
dbname
(use-ssl :no))
(apply #'append uri)
(declare (ignore type))
;;
;; Default to environment variables as described in
;; http://www.postgresql.org/docs/9.3/static/app-psql.html
;; http://dev.mysql.com/doc/refman/5.0/en/environment-variables.html
;;
(list (or dbname (getenv-default "PGDATABASE" user))
(or user (getenv-default "PGUSER" (getenv-default "USER")))
(or password (getenv-default "PGPASSWORD"))
(or (when host
(destructuring-bind (type &optional name) host
(ecase type
(:unix (or name :unix))
(:ipv4 name)
(:host name))))
(getenv-default "PGHOST"
#+unix :unix
#-unix "localhost"))
:port (or port
(parse-integer (getenv-default "PGPORT" "5432")))
:use-ssl use-ssl))))
;;;
;;; Parsing a connection string
;;;
(defun parse-pgsql-connection-string (connection-string)
"Parse given CONNECTION-STRING and return a Postmodern suitable connection
spec.
Examples:
IN: postgresql://dim@localhost:54393/pginstall
OUT: '(\"pginstall\" \"dim\" nil \"localhost\" :port 54393 :use-ssl :no)
The default port, when omitted, comes from the environment variable PGPORT."
(parse 'db-connection-uri connection-string))
(defmacro with-pgsql-connection ((connection-string) &body body)
"Runs BODY within an established PostgreSQL connection."
`(with-connection (parse-pgsql-connection-string ,connection-string)
,@body))
;;;
;;; Validating a connection string
;;;
(defun validate-dburi (connection-string)
"Signal an error when CONNECTION-STRING either can't be parsed or if we
can't connect to a PostgreSQL server when using it."
(with-pgsql-connection (connection-string)
(query "SELECT 1" :single))
;; make sure to return the valid connection-string
connection-string)
pgcharts/src/utils/cli-parser.lisp 0000644 0001750 0001750 00000012561 12375720021 017444 0 ustar vagrant vagrant (in-package #:pgcharts)
(eval-when (:load-toplevel :compile-toplevel :execute)
(defstruct command verbs bindings help lambda)
(defvar *commands* (make-array 0
:element-type 'command
:adjustable t
:fill-pointer t)
"Host commands defined with the DEFINE-COMMAND macro.")
(defmethod same-command ((a command) (b command))
"Return non-nil when a and b are commands with the same verbs"
(equal (command-verbs a) (command-verbs b))))
(defun destructuring-match (lambda-list args)
"Return non-nil when ARGS are matching against the given LAMBDA-LIST."
(ignore-errors
(funcall
(compile nil
`(lambda ()
;; hide a style warning that variables are defined
;; but never used here
(declare #+sbcl (sb-ext:muffle-conditions style-warning))
(destructuring-bind ,lambda-list ',args t))))))
(defmethod command-matches ((command command) args)
"When the given COMMAND matches given command line ARGS, then return it
and the argument to apply to it."
(declare (type list args))
(when (<= (length (command-verbs command)) (length args))
(let ((matches-p (loop :for verb :in (command-verbs command)
:for arg in args
:for matches-p := (string-equal verb arg)
:while matches-p
:finally (return matches-p))))
(when matches-p
(let ((fun-args (nthcdr (length (command-verbs command)) args)))
(when (destructuring-match (command-bindings command) fun-args)
(list (command-lambda command) fun-args)))))))
(defmacro define-command ((verbs bindings) help-string &body body)
"Define a command that is to be fired when VERBS are found at the
beginning of the command, assigning remaining arguments to given
bindings.
The help-string is used when displaying the program usage."
(let ((fun (gensym))
(command (gensym))
(position (gensym))
(output (gensym)))
`(eval-when (:load-toplevel :compile-toplevel :execute)
(let* ((,fun (lambda ,bindings
(read-config)
(let ((,output (progn ,@body)))
(typecase ,output
(string (format t "~a~%" ,output))
(t nil)))))
(,command (make-command :verbs ',verbs
:bindings ',bindings
:help ,help-string
:lambda (compile nil ,fun)))
(,position (position-if (lambda (c) (same-command c ,command))
*commands*)))
(if ,position
(setf (aref *commands* ,position) ,command)
(vector-push-extend ,command *commands*))))))
(defstruct (option
(:conc-name opt-)
(:constructor make-option (keyword short long
&optional fun eat-next-arg)))
keyword short long fun eat-next-arg)
(defun parse-option-name (arg)
"When ARG is an option name, return its keyword, otherwise return nil."
(loop :for option :in *options*
:when (or (string= arg (opt-short option))
(string= arg (opt-long option)))
:return option))
(defun process-argv-options (argv)
"Return the real args found in argv, and a list of the options used, as
multiple values."
(let ((args '())
(ignore nil)
(opts '()))
(values (loop :for (arg next) :on (rest argv)
:for opt := (unless ignore (parse-option-name arg))
:do (progn
;; sanity check
(when (and opt (opt-eat-next-arg opt) (null next))
(format t "Missing argument for option ~a~%" arg)
(push :help opts))
;; build the argument list
(unless (or opt ignore)
(push arg args))
;; we might have to ignore arg on next iterationa
(setf ignore (and opt (opt-eat-next-arg opt)))
;; deal with the option side effects
(when opt
(push (opt-keyword opt) opts)
(when (opt-fun opt)
(let ((args (when (opt-eat-next-arg opt) (list next))))
(apply (opt-fun opt) args)))))
:finally (return (nreverse args)))
opts)))
(defun find-command-function (args)
"Loop through *COMMANDS* to find the code to execute given ARGS."
(loop :for command :across *commands*
:for match := (command-matches command args)
:until match
:finally (return match)))
(defun usage (args &key help)
"Loop over all the commands and output the usage of the main program"
(format t "pgcharts [ --help ] [ --version ] [ --config filename ] command ...~%")
(unless help
(format t "~a: command line parse error.~%" (first args))
(format t "~@[Error parsing args: ~{~s~^ ~}~%~]~%" (rest args)))
(format t "~%Available commands:~%")
(loop :for command :across *commands*
:do (with-slots (verbs bindings help) command
(format t " ~{~a~^ ~} ~{~a~^ ~}~28T~a~%" verbs bindings help))))
pgcharts/src/utils/cache.lisp 0000644 0001750 0001750 00000010222 12375662302 016445 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Cache all the on-disk static files (bootstrap, jquery, css, markdown
;;; docs etc) at load time so that we can have an all-included binary file
;;; for real.
;;;
;;; Hunchentoot web server integration
;;;
(defun handle-loaded-file (script-name &optional content-type)
"A function which act like the hunchentoot::handle-static-file function,
against our *fs* in-memory pseudo file-system."
(let ((content (gethash script-name *fs*)))
(unless content
;; file does not exist
(setf (hunchentoot::return-code*) hunchentoot::+http-not-found+)
(hunchentoot::abort-request-handler))
(let (bytes-to-send)
(setf (hunchentoot::content-type*) (or content-type
(hunchentoot:mime-type script-name)
"application/octet-stream")
(hunchentoot:header-out :last-modified) (hunchentoot::rfc-1123-date
(get-universal-time))
(hunchentoot::header-out :accept-ranges) "bytes")
;;
;; To simplify stealing code from hunchentoot
;;
(flexi-streams:with-input-from-sequence (file content)
(setf bytes-to-send (maybe-handle-range-header file (length content))
(hunchentoot::content-length*) bytes-to-send)
(let ((out (hunchentoot::send-headers))
(buf (make-array hunchentoot::+buffer-length+
:element-type '(unsigned-byte 8))))
(loop
(when (zerop bytes-to-send)
(return))
(let* ((chunk-size (min hunchentoot::+buffer-length+ bytes-to-send)))
(unless (eql chunk-size (read-sequence buf file :end chunk-size))
(error "can't read from input file"))
(write-sequence buf out :end chunk-size)
(decf bytes-to-send chunk-size)))
(finish-output out))))))
(defun create-loaded-file-dispatcher-and-handler
(uri-prefix base-path &optional content-type)
"Creates and returns a dispatch function which will dispatch to a
handler function which emits the file relative to BASE-PATH that is
denoted by the URI of the request relative to URI-PREFIX. URI-PREFIX
must be a string ending with a slash, BASE-PATH must be a pathname
designator for an existing directory. If CONTENT-TYPE is not NIL,
it'll be the content type used for all files in the folder."
(flet ((handler ()
(let ((request-path
(hunchentoot::request-pathname hunchentoot::*request* uri-prefix)))
(when (null request-path)
(setf (hunchentoot::return-code*) hunchentoot::+http-forbidden+)
(hunchentoot::abort-request-handler))
(handle-loaded-file (merge-pathnames request-path base-path)
content-type))))
(hunchentoot::create-prefix-dispatcher uri-prefix #'handler)))
;;;
;;; Rework some hunchentoot internals that expect file streams so that they
;;; work with our in-memory implementation: file-length is signaling.
;;;
(defun maybe-handle-range-header (file length)
"Helper function for handle-static-file. Determines whether the
requests specifies a Range header. If so, parses the header and
position the already opened file to the location specified. Returns
the number of bytes to transfer from the file. Invalid specified
ranges are reported to the client with a HTTP 416 status code."
(let ((bytes-to-send length))
(cl-ppcre:register-groups-bind
(start end)
("^bytes=(\\d+)-(\\d*)$" (hunchentoot::header-in* :range) :sharedp t)
;; body won't be executed if regular expression does not match
(setf start (parse-integer start))
(setf end (if (> (length end) 0)
(parse-integer end)
(1- length)))
(when (or (< start 0)
(>= end length))
(setf (hunchentoot::return-code*)
hunchentoot::+http-requested-range-not-satisfiable+
(hunchentoot::header-out :content-range)
(format nil "bytes 0-~D/~D" (1- length) length))
(throw 'handler-done
(format nil "invalid request range (requested ~D-~D, accepted 0-~D)"
start end (1- length))))
(file-position file start)
(setf (hunchentoot::return-code*)
hunchentoot::+http-partial-content+
bytes-to-send
(1+ (- end start))
(hunchentoot::header-out :content-range)
(format nil "bytes ~D-~D/~D" start end length)))
bytes-to-send))
pgcharts/src/utils/read-sql-files.lisp 0000644 0001750 0001750 00000020114 12377635435 020224 0 ustar vagrant vagrant ;;;
;;; Tools to get the list of query from the model.sql, api.sql and sql/*.sql
;;; files, which remains usable as-is interactively (hence the injecting
;;; trick)
;;;
(in-package #:pgcharts.sql)
(defstruct parser
filename
(stream (make-string-output-stream))
(state :eat)
tags)
(defmethod print-object ((p parser) stream)
(print-unreadable-object (p stream :type t :identity t)
(with-slots (state tags) p
(format stream "~a {~{~s~^ ~}}" state tags))))
(defmethod push-new-tag ((p parser))
"Add a new element on the TAGS slot, a stack"
(let ((tag (make-array 42
:fill-pointer 0
:adjustable t
:element-type 'character)))
(push tag (parser-tags p))))
(defmethod extend-current-tag ((p parser) char)
"The TAGS slot of the parser is a stack, maintain it properly."
(declare (type character char))
(assert (not (null (parser-tags p))))
(vector-push-extend char (first (parser-tags p))))
(defmethod format-current-tag ((p parser) &optional (stream (parser-stream p)))
"Output the current tag to the current stream."
(format stream "$~a$" (coerce (first (parser-tags p)) 'string)))
(defmethod maybe-close-tags ((p parser) &optional (stream (parser-stream p)))
"If the two top tags in the TAGS slot of the parser P are the
same (compared using EQUALP), then pop them out of the stack and print
the closing tag to STREAM."
(when (and (< 1 (length (parser-tags p)))
(equalp (first (parser-tags p))
(second (parser-tags p))))
;; format the tag in the stream and POP both entries
(format-current-tag p stream)
(pop (parser-tags p))
(pop (parser-tags p))
;; and return t
t))
(defmethod pop-current-tag ((p parser))
"Remove current tag entry"
(pop (parser-tags p)))
(defmethod reset-state ((p parser))
"Depending on the current tags stack, set P state to either :eat or :eqt"
(setf (parser-state p) (if (null (parser-tags p)) :eat :eqt)))
#|
Here's a test case straigth from the PostgreSQL docs:
(with-input-from-string (s "
create function f(text)
returns bool
language sql
as $function$
BEGIN
RETURN ($1 ~ $q$[\\t\\r\\n\\v\\\\]$q$);
END;
$function$;")
(parse-query s (make-parser)))
Another test case for the classic quotes:
(with-pgsql-connection ("pgsql:///pginstall")
(query
(with-input-from-string (s "select E'\\';' as \";\";")
(parse-query s)) :alists))
should return
(((:|;| . "';")))
|#
(defun parse-query (stream &optional (state (make-parser)))
"Read a SQL query from STREAM, starting at whatever the current position is.
Returns another SQL query each time it's called, or NIL when EOF is
reached expectedly. Signal end-of-file condition when reaching EOF in the
middle of a query.
See the following docs for some of the parser complexity background:
http://www.postgresql.org/docs/9.3/static/sql-syntax-lexical.html#SQL-SYNTAX-DOLLAR-QUOTING
Parser states are:
- EAT reading the query
- TAG reading a tag that could be an embedded $x$ tag or a closing tag
- EOT End Of Tag
- EQT Eat Quoted Text
- EDQ Eat Double-Quoted Text (identifiers)
- EOQ done reading the query
- ESC read espaced text (with backslash)"
(handler-case
(loop
:until (eq :eoq (parser-state state))
:for char := (read-char stream)
:do (case char
(#\\ (case (parser-state state)
(:esc (setf (parser-state state) :eqt))
(:eqt (setf (parser-state state) :esc)))
(write-char char (parser-stream state)))
(#\' (case (parser-state state)
(:eat (setf (parser-state state) :eqt))
(:esc (setf (parser-state state) :eqt))
(:eqt (setf (parser-state state) :eat)))
(write-char char (parser-stream state)))
(#\" (case (parser-state state)
(:eat (setf (parser-state state) :edq))
(:edq (setf (parser-state state) :eat)))
(write-char char (parser-stream state)))
(#\$ (case (parser-state state)
(:eat (setf (parser-state state) :tag))
(:eqt (setf (parser-state state) :tag))
(:tag (setf (parser-state state) :eot)))
;; we act depending on the NEW state
(case (parser-state state)
(:eat (write-char char (parser-stream state)))
(:tag (push-new-tag state))
(:eot ; check the tag stack
(cond ((= 1 (length (parser-tags state)))
;; it's an opening tag, collect the text now
(format-current-tag state)
(reset-state state))
(t ; are we closing the current tag?
(if (maybe-close-tags state)
(reset-state state)
;; not the same tags, switch state back
;; don't forget to add the opening tag
(progn
(format-current-tag state)
(setf (parser-state state) :eqt))))))))
(#\; (case (parser-state state)
(:eat (setf (parser-state state) :eoq))
(otherwise (write-char char (parser-stream state)))))
(otherwise (cond ((member (parser-state state) '(:eat :eqt))
(write-char char (parser-stream state)))
((member (parser-state state) '(:tag))
;; only letters are allowed in tags
(if (alpha-char-p char)
(extend-current-tag state char)
(progn
;; not a tag actually: remove the
;; parser-tags entry and push back its
;; contents to the main output stream
(let ((tag (pop-current-tag state)))
(format (parser-stream state)
"$~a~c"
tag
char))
(reset-state state)))))))
:finally (return
(get-output-stream-string (parser-stream state))))
(end-of-file (e)
(unless (eq :eat (parser-state state))
(error e)))))
(defun read-lines (filename &optional (q (make-string-output-stream)))
"Read lines from given filename and return them in a stream. Recursively
apply \i include instructions."
(with-open-file (s filename :direction :input)
(loop
for line = (read-line s nil)
while line
do (if (or (and (> (length line) 3)
(string= "\\i " (subseq line 0 3)))
(and (> (length line) 4)
(string= "\\ir " (subseq line 0 4))))
(let ((include-filename
(merge-pathnames (subseq line 3)
(directory-namestring filename))))
(read-lines include-filename q))
(format q "~a~%" line))
finally (return q))))
(defun read-queries (filename)
"read SQL queries in given file and split them, returns a list"
(let ((file-content (get-output-stream-string (read-lines filename))))
(with-input-from-string (s file-content)
(loop :for query := (parse-query s)
:while query
:collect query))))
pgcharts/src/front-query.lisp 0000644 0001750 0001750 00000034121 12563456136 016546 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Frontend for query editing and result display (text or graph)
;;;
(defvar *chart-types* '("Raw" "Column" "Bar" "Pie" "Donut")
"Known chart types.")
(defun front-edit-query (&optional qid form-style)
"Return the HTML to display a query form."
(destructuring-bind (&key q ((:d dbname-list)))
(with-pgsql-connection (*dburi*)
(list :q (if qid (get-dao 'query (parse-integer qid :radix 36))
(make-instance 'query
:dbname ""
:qname ""
:description ""
:sql ""
:cats ""
:series ""
:xtitle ""
:ytitle ""
:chart-type ""))
:d (query "select dbname from db order by 1" :column)))
(when (string= "Raw" (chart-type q))
(hunchentoot:redirect (q/raw/url q)
:code hunchentoot:+http-moved-temporarily+))
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:h1 :class "page-header" :style form-style "SQL Query")
(:form :role "query"
:id "run-query"
:method "post"
:action "/q/save"
:class "form-horizontal"
:style form-style
(:input :type "hidden" :id "qid" :name "qid" :value qid)
(:div :class "form-group"
(:label :for "dbname" :class "col-sm-3 control-label"
"Database name")
(:div :class "col-sm-9"
(:select :id "dbname"
:name "dbname"
:class "form-control"
(loop :for dbname :in dbname-list
:for on := (string= dbname (dbname q))
:do (htm (:option :selected on
(str dbname)))))))
(:div :class "form-group"
(:label :for "qname" :class "col-sm-3 control-label"
"Query name")
(:div :class "col-sm-9"
(:input :type "text" :name "qname" :id "qname"
:placeholder "Enter query name"
:class "form-control"
:value (qname q))))
(:div :class "form-group"
(:label :for "qdesc" :class "col-sm-3 control-label"
"Query description")
(:div :class "col-sm-9"
(:input :type "text" :name "qdesc" :id "qdesc"
:placeholder "Enter query description"
:class "form-control"
:value (qdesc q))))
(:div :class "form-group"
(:label :for "cats" :class "col-sm-3 control-label"
"Categories (x axis)")
(:div :class "col-sm-3"
(:input :type "text" :name "cats" :id "cats"
:placeholder "Enter categories column name"
:class "form-control"
:value (qcats q)))
(:label :for "xtitle" :class "col-sm-2 control-label"
"X Legend")
(:div :class "col-sm-4"
(:input :type "text" :name "xtitle" :id "xtitle"
:placeholder "Enter categories legend"
:class "form-control"
:value (xtitle q))))
(:div :class "form-group"
(:label :for "series" :class "col-sm-3 control-label"
"Data series")
(:div :class "col-sm-3"
(:input :type "text" :name "series" :id "series"
:placeholder "Enter data series column name"
:class "form-control"
:value (qseries q)))
(:label :for "ytitle" :class "col-sm-2 control-label"
"Y Legend")
(:div :class "col-sm-4"
(:input :type "text" :name "ytitle" :id "ytitle"
:placeholder "Enter series legend"
:class "form-control"
:value (ytitle q))))
(:div :class "form-group"
(:label :for "query" :class "col-sm-3 control-label"
"Query SQL")
(:div :class "col-sm-9"
(:textarea :id "query" :name "query" :rows "25"
(str (qsql q)))))
(:div :class "form-group"
(:div :class "col-sm-offset-3 col-sm-2"
(:button :id "btn-run-query"
:class "btn btn-success"
:type "button" "Run Query"))
(:label :for "chart-type" :class "col-sm-3 control-label"
"Default Chart Type")
(:div :class "col-sm-2"
(:select :id "chart-type"
:name "chart-type"
:class "form-control"
(loop :for type :in *chart-types*
:for on := (string= type (chart-type q))
:do (htm (:option :selected on
(str type))))))
(:div :class "col-sm-2"
(:button :id "btn-save-query"
:class "btn btn-primary"
:type "submit" "Save Query"))))
(:script "
var myCodeMirror = CodeMirror.fromTextArea(query, {
lineWrapping: true,
lineNumbers: true,
styleActiveLine: true,
matchBrackets: true,
mode: \"text/x-plsql\",
theme: \"elegant\"
});"))))))
(defun front-query-result (&optional (title "Query Results"))
"Display query result, with tabs for different charts types."
(with-html-output-to-string (s)
(htm
(:div :class "col-sm-9 col-sm-offset-3 col-md-10 col-md-offset-2 main"
(:h1 :class "page-header" (str title))
(:ul :id "charts" :class "nav nav-tabs"
(:li :class "active"
(:a :id "raw" :href "#raw"
(:span :class "glyphicon glyphicon-th"
" Raw Results")))
(:li (:a :id "column" :href "#column"
(:span :class "glyphicon glyphicon-stats")
" Column Chart"))
(:li (:a :id "bar" :href "#bar"
(:span :class "glyphicon glyphicon-align-left")
" Bar Chart"))
(:li (:a :id "pie" :href "#pie"
(:span :class "glyphicon glyphicon-dashboard")
" Pie Chart"))
(:li (:a :id "donut" :href "#donut"
(:span :class "glyphicon glyphicon-record")
" Donut Chart")))
(:div :id "qresult")))))
(defun front-new-query ()
"Allow user to enter a new query."
(serve-page
(with-html-output-to-string (s)
(htm
(str (front-edit-query))
(str (front-query-result))))))
(defun front-display-query (qid)
"Allow user to run and edit a known query."
(serve-page
(with-html-output-to-string (s)
(htm
(str (front-edit-query qid))
(str (front-query-result))))))
(defun front-display-query-chart (qid)
"Display only the #qresult pane for given query."
(let ((q (with-pgsql-connection (*dburi*)
(get-dao 'query (parse-integer qid :radix 36)))))
(serve-page
(with-html-output-to-string (s)
(htm
(str (front-edit-query qid "display: none;"))
(str (front-query-result (qdesc q)))
(:script "doit = true;"))))))
(defun front-fetch-csv-data ()
"Given an SQL query and a connection string given as POST parameters,
return the query result-set as CSV data."
(setf (hunchentoot:content-type*) "text/plain")
(let* ((dbname (hunchentoot:post-parameter "dbname"))
(query (hunchentoot:post-parameter "query"))
(qdburi (with-pgsql-connection (*dburi*)
(db-uri (get-dao 'db dbname)))))
(handler-case
(let ((data (with-pgsql-connection (qdburi) (query query))))
(with-output-to-string (s)
(loop :for row :in data
:do (format s "~&~{\"~a\"~^,~}" row))))
(database-error (e)
(hunchentoot:log-message* :error "condition: ~a" e)
(with-output-to-string (s)
(yason:encode-alist `((:sqlstate . ,(database-error-code e))
(:message . ,(database-error-message e))
(:detail . ,(database-error-detail e))
(:hint . ,(database-error-hint e))
(:context . ,(database-error-context e))
(:query . ,(database-error-query e))
(:position . ,(database-error-position e))
(:cause . ,(database-error-cause e)))
s))))))
(defun front-fetch-json-data ()
"Given an SQL query and a connection string given as POST parameters,
return the query result-set as CSV data."
(setf (hunchentoot:content-type*) "text/plain")
(let* ((dbname (hunchentoot:post-parameter "dbname"))
(query (hunchentoot:post-parameter "query"))
(qdburi (with-pgsql-connection (*dburi*)
(db-uri (get-dao 'db dbname)))))
(handler-case
(let ((data (with-pgsql-connection (qdburi) (query query :alists))))
(hunchentoot:log-message* :error "data: ~a" data)
(format nil "[~{~a~^, ~}]"
(loop :for row :in data
:collect (with-output-to-string (s)
(yason:encode-alist row s)))))
(database-error (e)
(hunchentoot:log-message* :error "condition: ~a" e)
(with-output-to-string (s)
(yason:encode-alist `((:sqlstate . ,(database-error-code e))
(:message . ,(database-error-message e))
(:detail . ,(database-error-detail e))
(:hint . ,(database-error-hint e))
(:context . ,(database-error-context e))
(:query . ,(database-error-query e))
(:position . ,(database-error-position e))
(:cause . ,(database-error-cause e)))
s))))))
(defun front-save-query ()
"Save SQL query as given by form."
(let ((dbname (hunchentoot:post-parameter "dbname"))
(qid (hunchentoot:post-parameter "qid"))
(qname (hunchentoot:post-parameter "qname"))
(qdesc (hunchentoot:post-parameter "qdesc"))
(query (hunchentoot:post-parameter "query"))
(qcats (or (hunchentoot:post-parameter "cats") :null))
(qseries (or (hunchentoot:post-parameter "series") :null))
(xtitle (or (hunchentoot:post-parameter "xtitle") :null))
(ytitle (or (hunchentoot:post-parameter "ytitle") :null))
(chart-type (or (hunchentoot:post-parameter "chart-type") "Raw")))
(with-pgsql-connection (*dburi*)
;; basically insert or update, depending on whether we already have a
;; query id or not.
(let ((query
(if (and qid (not (string= "" qid)))
;; update existing query that we have the id of
(update-dao (make-instance 'query
:id (parse-integer qid :radix 36)
:dbname dbname :qname qname
:description qdesc :sql query
:cats qcats :series qseries
:xtitle xtitle :ytitle ytitle
:chart-type chart-type))
;; create a new query in the pgcharts database
(make-dao 'query
:dbname dbname
:qname qname :description qdesc :sql query
:cats qcats :series qseries
:xtitle xtitle :ytitle ytitle :chart-type chart-type))))
;; and now redirect to editing that same query
(hunchentoot:redirect (q/url query)
:code hunchentoot:+http-moved-temporarily+)))))
(defun front-delete-query (id)
"Delete given query then get back on the listing page."
(with-pgsql-connection (*dburi*)
(delete-dao (make-instance 'query :id (parse-integer id :radix 36))))
;; and back to the listing
(hunchentoot:redirect "/" :code hunchentoot:+http-moved-temporarily+))
pgcharts/src/package.lisp 0000644 0001750 0001750 00000002347 12563446747 015662 0 ustar vagrant vagrant (defpackage #:pgcharts.dburi
(:use #:cl #:esrap)
(:import-from #:postmodern
#:with-connection
#:query)
(:export #:parse-pgsql-connection-string
#:validate-dburi
#:with-pgsql-connection))
(defpackage #:pgcharts.sql
(:use #:cl)
(:export #:read-queries))
(defpackage #:pgcharts
(:use #:cl
#:postmodern
#:simple-routes
#:cl-who
#:pgcharts.dburi
#:pgcharts.sql)
(:import-from #:alexandria
#:read-file-into-string
#:read-file-into-byte-vector)
(:import-from #:split-sequence
#:split-sequence)
(:import-from #:cl-postgres
#:database-error
#:database-error-code
#:database-error-message
#:database-error-detail
#:database-error-hint
#:database-error-context
#:database-error-query
#:database-error-position
#:database-error-cause)
(:export #:*acceptor*
#:*server-is-running*
#:start-server
#:stop-server
#:restart-server))
;;;
;;; Package aliasing
;;;
(rename-package 'py-configparser 'py-configparser '(ini))
pgcharts/src/model.sql 0000644 0001750 0001750 00000001401 12377622023 015167 0 ustar vagrant vagrant ---
--- pgcharts model
---
create schema if not exists pgcharts;
create table pgcharts.catalog
(
version text primary key
);
create table pgcharts.db
(
dbname text primary key,
dburi text
);
-- the minvalue is just so that we begin with 3 letters URLs
create sequence pgcharts.query_id_seq minvalue 10000;
create table pgcharts.query
(
id bigint not null default nextval('pgcharts.query_id_seq') primary key,
db text not null references pgcharts.db(dbname),
qname text unique not null,
description text,
sql text,
cats text,
series text,
x_title text,
y_title text,
chart_type text
);
alter sequence pgcharts.query_id_seq owned by pgcharts.query.id;
pgcharts/src/server.lisp 0000644 0001750 0001750 00000005144 12572256023 015555 0 ustar vagrant vagrant (in-package #:pgcharts)
(defvar *routes*
(compile-routes
;; Home page
(:GET "/" 'front-list-queries)
;; Resources
(:GET "/js/.*" 'serve-resource) ; Our own javascript glue
(:GET "/dist/.*" 'serve-resource) ; Bootstrap
(:GET "/highcharts/.*" 'serve-resource) ; HighCharts
(:GET "/images/.*" 'serve-resource) ; Static images
(:GET "/cm/.*" 'serve-resource) ; CodeMirror
(:GET "/hallo/.*" 'serve-resource) ; Hallo.js
(:GET "/fa/.*" 'serve-resource) ; FontAwesome
;; Server status and control
(:GET "/status" 'front-server-status)
;; Queries
(:GET "/q/new" 'front-new-query)
(:GET "/q/raw/:id" 'front-raw-query)
(:GET "/q/raw" 'front-raw-query)
(:POST "/q/raw" 'front-raw-query) ; one-page style form
(:POST "/q/save" 'front-save-query)
(:GET "/q/del/:id" 'front-delete-query)
(:GET "/q/:id" 'front-display-query)
;; Charts only
(:GET "/c/:id" 'front-display-query-chart)
;; AJAX API to get at query result data
(:POST "/json" 'front-fetch-json-data)
(:POST "/csv" 'front-fetch-csv-data)
;; Database browser
(:GET "/d/:dbname" 'front-browse-database)
;; Search
(:GET "/s" 'front-search-queries)
;; Document editing, trying hallo.js for an SQL Notebook
(:GET "/nb" 'front-new-notebook)))
(defvar *acceptor* nil "The Web Server")
(defvar *server-is-running* nil)
(defun start-server (&key (logs *terminal-io*))
"Start the web server"
(read-config)
(when *acceptor*
(error "The web server is already running."))
(setf *acceptor* (make-instance 'simpleroutes-acceptor
:routes '*routes*
:address (copy-seq *listen-address*)
:port *listen-port*
:document-root nil
:access-log-destination logs
:message-log-destination logs))
(hunchentoot:start *acceptor*)
(setf *server-is-running* t))
(defun stop-server ()
"Stop the web server"
(unless *acceptor*
(error "The web server isn't running."))
(hunchentoot:stop *acceptor*)
(setf *acceptor* nil *server-is-running* nil))
(defun restart-server ()
(stop-server)
(start-server))
(defun front-server-status ()
"Return OK when the server is OK."
(setf (hunchentoot:content-type*) "text/plain")
"OK")
pgcharts/src/resources.lisp 0000644 0001750 0001750 00000007174 12416476742 016277 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; When building a self-contained binary, we want to load all static
;;; resources in-memory.
;;;
(defun load-static-file (fs pathname url-path)
"Load given PATHNAME contents at URL-PATH in FS."
(setf (gethash url-path fs)
(read-file-into-byte-vector pathname)))
(defun pathname-to-url (pathname url-path)
"Transform given PATHNAME into an URL at which to serve it within URL-PATH."
(multiple-value-bind (flag path-list last-component file-namestring-p)
(uiop:split-unix-namestring-directory-components
(uiop:native-namestring pathname))
(declare (ignore flag file-namestring-p))
(format nil "~a~{/~a~}/~a" url-path path-list last-component)))
(defun load-static-directory (fs root url-path)
"Walk PATH and load all files found in there as binary sequence, FS being
an hash table referencing the full path against the bytes."
(flet ((collectp (dir) (declare (ignore dir)) t)
(recursep (dir) (declare (ignore dir)) t)
(collector (dir)
(loop :for pathname :in (uiop:directory-files dir)
:unless (or (uiop:directory-pathname-p pathname)
(string= "zip" (pathname-type pathname)))
:do (let ((url (pathname-to-url
(uiop:enough-pathname pathname root) url-path)))
(load-static-file fs pathname url)))))
(uiop:collect-sub*directories root #'collectp #'recursep #'collector)))
(defvar *url-to-dir-mapping* `(("js" . ,*js-root*)
("dist" . ,*bootstrap-root*)
("highcharts" . ,*highcharts-root*)
("cm" . ,*codemirror-root*)
("images" . ,*images-root*)
("hallo" . ,*hallo-root*)
("fa" . ,*fontawesome-root*))
"Map URL first directory to its on-disk locations.")
(defparameter *fs*
(let ((fs (make-hash-table :test #'equal)))
(loop :for (first-dir . root ) :in *url-to-dir-mapping*
:for url-path := (format nil "/~a" first-dir)
:for root-dir := (uiop:ensure-directory-pathname root)
:do (load-static-directory fs root-dir url-path))
fs)
"File system as an hash-table in memory.")
(defparameter *header* (read-file-into-string *header-path*))
(defparameter *footer* (read-file-into-string *footer-path*))
;;;
;;; General tools to render web static resources
;;;
;;;
;;; Single files
;;;
(defun serve-header ()
"Serve the header file."
(if *serve-from-cache* *header*
(read-file-into-string *header-path*)))
(defun serve-footer ()
"Serve the footer file."
(if *serve-from-cache* *footer*
(read-file-into-string *footer-path*)))
;;;
;;; Sub-directories
;;;
(defun serve-resource-from-file (&optional
(script-name (hunchentoot:script-name*)))
"Serve a static resource from a file"
(destructuring-bind (first-dir &rest components)
;; the url always begins with a / and we skip it
(cdr (split-sequence #\/ script-name))
(let* ((root (cdr (assoc first-dir *url-to-dir-mapping* :test #'string=)))
(filename (format nil "~a/~{~a~^/~}" root components)))
(hunchentoot:handle-static-file filename))))
(defun serve-resource-from-cache (&optional
(script-name (hunchentoot:script-name*)))
"Serve a static resource from the cache"
(handle-loaded-file script-name))
(defun serve-resource ()
"Serve a static resource"
(if *serve-from-cache*
(serve-resource-from-cache)
(serve-resource-from-file)))
pgcharts/src/model.lisp 0000644 0001750 0001750 00000015065 12400065623 015344 0 ustar vagrant vagrant (in-package #:pgcharts)
;;;
;;; Tools to install our model.sql objects into the database
;;;
(defparameter *model*
(read-queries
(asdf:system-relative-pathname :pgcharts "src/model.sql"))
"The SQL model as a list of queries.")
(defparameter *catversion* "20140828"
"Version number for the catalog.")
(defparameter *model-table-list*
(sort
(remove-if #'null
(mapcar (lambda (sql) (cl-ppcre:register-groups-bind (table-name)
("create table ([A-Za-z_.]+)" sql)
table-name))
*model*))
#'string<)
"List of table names expected to be created by *model*, to allow for
checking if the setup has been made.")
(defun model-version (&optional (dburi *dburi*))
"Check that we find all our table definitions."
(with-pgsql-connection (dburi)
(let ((table-list (query "select nspname || '.' || relname as relname
from pg_class c
join pg_namespace n
on c.relnamespace = n.oid
where n.nspname = 'pgcharts'
and c.relkind = 'r'
order by relname"
:column)))
(if (member "pgcharts.catalog" table-list :test #'string=)
(query "select version from pgcharts.catalog" :single)
(when (equalp table-list '("pgcharts.db" "pgcharts.query"))
"20140823")))))
(defun install-model-from-scratch (&optional (dburi *dburi*))
"Check that the given database connection DBURI contains the SQL data
model as defined in *model*."
(with-pgsql-connection (dburi)
(with-transaction ()
(loop :for sql :in *model* :do (query sql))
;; and an extra SQL statement is needed here
(destructuring-bind (dbname &rest ignore)
(parse-pgsql-connection-string dburi)
(declare (ignore ignore))
(execute "insert into pgcharts.catalog(version) values($1)" *catversion*)
(execute (format nil "alter database ~a set search_path to pgcharts"
dbname))))))
(defun upgrade-model (current-version &optional (dburi *dburi*))
"Upgrade the database model by rolling out SQL upgrade scripts."
(let ((script-name-list (find-update-path current-version *catversion*)))
(loop :for script-name :in script-name-list
:for queries := (cdr (assoc script-name *upgrade-scripts* :test #'string=))
:do (with-pgsql-connection (dburi)
(format t "Rolling out upgrade script ~a~%" script-name)
(with-transaction ()
(loop :for sql :in queries :do (query sql)))))))
(defun ensure-model-is-current (&optional (dburi *dburi*))
"Check the current model's version and upgrade it if needed."
(let ((version (model-version dburi)))
(cond ((null version)
(format t "Installing pgcharts database model.~%")
(install-model-from-scratch dburi))
((string/= version *catversion*)
(format t "Upgrading pgcharts database model.~%")
(upgrade-model version)))))
;;;
;;; Data Access Objects
;;;
;;; Allow to easily manage CRUD operations
;;;
(defclass db ()
((dbname :col-type integer :accessor dbname :initarg :dbname)
(dburi :col-type string :accessor db-uri :initarg :dburi))
(:documentation
"a database connection string, where to run queries.")
(:metaclass dao-class)
(:keys dbname))
(defmethod print-object ((db db) stream)
(print-unreadable-object (db stream :type t :identity t)
(db-uri db stream)))
;;;
;;; Save the queries!
;;;
(defclass query ()
((id :col-type integer :reader qid :initarg :id)
(dbname :accessor dbname :initarg :dbname
:col-type string :col-name db)
(qname :col-type string :accessor qname :initarg :qname)
(description :col-type string :accessor qdesc :initarg :description)
(sql :col-type integer :accessor qsql :initarg :sql)
(cats :col-type string :accessor qcats :initarg :cats)
(series :col-type string :accessor qseries :initarg :series)
(xtitle :col-type string :col-name x_title
:accessor xtitle :initarg :xtitle)
(ytitle :col-type string :col-name y_title
:accessor ytitle :initarg :ytitle)
(chart-type :col-type string :col-name chart_type
:accessor chart-type :initarg :chart-type))
(:documentation
"a pgchart query")
(:metaclass dao-class)
(:keys id))
(defmethod print-object ((query query) stream)
(print-unreadable-object (query stream :type t :identity t)
(let ((qid (when (slot-boundp query 'id) (qid query))))
(with-slots (qname) query
(format stream "/q/~@[/~36r~] [~a]" qid qname)))))
(defmethod q/url ((query query))
"Return the HREF where to display and edit the query."
(format nil "/q/~36r" (qid query)))
(defmethod q/raw/url ((query query))
"Return the HREF where to display and edit the query."
(format nil "/q/raw/~36r" (qid query)))
(defmethod q/del/url ((query query))
"Return the HREF where to display and edit the query."
(format nil "/q/del/~36r" (qid query)))
(defmethod c/url ((query query))
"Return the HREF where to admire the query chart."
(format nil "/c/~36r" (qid query)))
;;;
;;; Monkey patch simple-date formatting
;;;
(defmethod print-object ((date simple-date:date) stream)
(multiple-value-bind (year month day) (simple-date:decode-date date)
(format stream "~2,'0d-~2,'0d-~4,'0d" day month year)))
(defmethod print-object ((stamp simple-date:timestamp) stream)
(multiple-value-bind (year month day hour min sec ms)
(simple-date:decode-timestamp stamp)
(format stream "~2,'0d-~2,'0d-~4,'0dT~2,'0d:~2,'0d:~2,'0d~@[,~3,'0d~]"
day month year hour min sec (if (zerop ms) nil ms))))
(defmethod print-object ((interval simple-date:interval) stream)
(multiple-value-bind (year month day hour min sec ms)
(simple-date:decode-interval interval)
(flet ((not-zero (x) (if (zerop x) nil x)))
(format stream "P~@[~dY~]~@[~dM~]~@[~dD~]~@[~dH~]~@[~dm~]~@[~d~@[,~3,'0d~]S~]"
(not-zero year) (not-zero month) (not-zero day)
(not-zero hour) (not-zero min)
(if (and (zerop sec) (zerop ms)) nil sec) (not-zero ms)))))
;;;
;;; And provide YaSON encoding functions
;;;
(defmethod yason:encode ((date simple-date:date)
&optional (stream *standard-output*))
(format stream "\"~a\"" date))
pgcharts/lib/ 0000755 0001750 0001750 00000000000 12336145467 013340 5 ustar vagrant vagrant pgcharts/lib/simple-routes-demo.lisp 0000644 0001750 0001750 00000006356 12305705674 017773 0 ustar vagrant vagrant ;;;
;;; https://raw.github.com/vancan1ty/simple-routes/master/simpleroutes-demo.lisp
;;;
;;; As I couldn't make Quicklisp and ASDF to load the project once git
;;; cloned in ~/quicklisp/local-projects/, let's just add a copy here.
(defpackage :simpleroutes-demo
(:use :common-lisp :hunchentoot :cl-who :simple-routes))
(in-package :simpleroutes-demo)
;;this should point to your static files root
(defvar *file-root* (cl-fad:merge-pathnames-as-directory *default-pathname-defaults* "web/"))
(setf simple-routes:*routeslist*
(compile-routes
;;html content uris
(:GET "" 'home-handler)
(:GET "/" 'home-handler)
(:GET "/people" 'home-handler)
(:GET "/people/:first/:last" 'get-people-handler)
(:GET "/people/put/:first/:last/:description" 'put-people-handler)
(:PUT "/people/:first/:last/:description" 'put-people-handler)
))
;all lat/long numbers are rounded to the hundredths place before insertion or checking...
(defvar *people-hash* (make-hash-table :test #'equalp))
;;add a couple of predefined peoples
(setf (gethash (list "Nikola" "Tesla") *people-hash*) "AC induction motor FTW!")
(setf (gethash (list "Thomas" "Edison") *people-hash*) "preferred DC")
(defun home-handler ()
(with-html-output-to-string (*standard-output* nil :indent t)
(:html
(:h1 "Simple-Routes Demo")
(:p "Look in simpleroutes-demo.lisp to see underlying code")
(:table :border 3
(:tr (:th "Operation") (:th "Urlspec") (:th "Description"))
(:tr (:td "GET") (:td "/people/:first/:last") (:td "retrieves matching person"))
(:tr (:td "PUT") (:td "/people/:first/:last/:description")
(:td "PUTs that name and description to the server"))
(:tr (:td "GET") (:td "/people/put/:first/:last/:description")
(:td "convenience accessor for PUT functionality using plain browser functionality"))
)
(:h2 "Current Entries")
(maphash (lambda (k v)
(htm (:p (print k) ": " (fmt v))))
*people-hash*)
)))
(defun get-people-handler (first last)
(with-html-output-to-string (*standard-output* nil :indent t)
(:html
(let ((potentialout (gethash (list first last) *people-hash*)))
(if potentialout
(htm (:p (fmt "name: ~a ~a" first last))
(:p (fmt "description: ~a" potentialout)))
(progn
(setf (return-code*) +HTTP-NOT-FOUND+)
(htm (:p "couldn't find that person!"))))))))
(defun put-people-handler (first last description)
(with-html-output-to-string (*standard-output* nil)
(:html
(:p (fmt "put: ~a " (setf (gethash (list first last) *people-hash*) (url-decode description)))))))
(defvar *macceptor* (make-instance 'simple-routes:simpleroutes-acceptor :port 8080
:document-root *file-root*
:access-log-destination *terminal-io*
:message-log-destination *terminal-io*))
(setf *show-lisp-errors-p* t
*show-lisp-backtraces-p* t)
;;code below restarts the acceptor every time this file is loaded
(if (hunchentoot::acceptor-shutdown-p *macceptor*)
(hunchentoot:start *macceptor*)
(progn
(hunchentoot:stop *macceptor*)
(hunchentoot:start *macceptor*)))
pgcharts/lib/simple-routes.lisp 0000644 0001750 0001750 00000012305 12336145467 017042 0 ustar vagrant vagrant ;;;
;;; https://raw.github.com/vancan1ty/simple-routes/master/simple-routes.lisp
;;;
;;; As I couldn't make Quicklisp and ASDF to load the project once git
;;; cloned in ~/quicklisp/local-projects/, let's just add a copy here.
(defpackage :simple-routes
(:use :common-lisp :cl-ppcre :hunchentoot)
(:export :compile-routes
:simpleroutes-acceptor
:simpleroutes-ssl-acceptor
:bind-alist-values
:define-simple-handler))
(in-package :simple-routes)
;;Adds simple-router dispatching to the front of hunchentoot's dispatch table!
(defvar *routeslist* ()
"should contain routes compiled with routespec-compile or manually entered in compiled form
incoming requests are matched up against each item in *routeslist* successively, until (and if) a
matching routespec is found.")
(defclass simpleroutes-acceptor (acceptor)
((routes :initarg :routes
:accessor routes
:documentation "Routes list."))
(:documentation
"This first tries to route requests using simple-router, then falls back
to hunchentoot's default easy-acceptor."))
#-:hunchentoot-no-ssl
(defclass simpleroutes-ssl-acceptor (simpleroutes-acceptor ssl-acceptor)
()
(:documentation "This is an acceptor that mixes the simpleroutes
acceptor with SSL connections."))
(defun issymbolstring (str)
(and (> (length str) 1) (eql (elt str 0) #\:)))
(defun removelast (sequence)
"removes the last item in sequence IF THE SEQUENCE HAS A LAST ITEM"
(if (> (length sequence) 0)
(subseq sequence 0 (1- (length sequence)))
sequence))
(defun routespec-compile (httpmethod urldef fntocall)
"httpmethod can be one of :GET :HEAD :POST :PUT :DELETE or :ALL
urldef is a url definition string sharing *basic* syntax with Ruby on Rails
fntocall is the function to call in case the this is found to be a match for the request
this macro returns a list which is meant to be processed by cl-simple routehandler
example call:
=>(rtreg :GET ``/home/next/:number'' #'nxthandler) returns
(:GET \"^/home/next/([^/]*)$\" (NUMBER)
#)
the output of this macro can in turn be processed by simple-processor"
(declare (optimize (debug 3)))
(let* ((thelist (remove "" (cl-ppcre:split "/" urldef) :test #'equalp))
(startswithslash (and (> (length urldef) 0) (eql (elt urldef 0) #\/)))
(endswithslash (and (> (length urldef) 1) (eql (lastitem urldef) #\/)))
(colonitems (reverse
(reduce (lambda (accum nxt)
(if (issymbolstring nxt)
(cons nxt accum)
accum))
thelist :initial-value ())))
(theregex (concatenate 'string
"^"
(when startswithslash "/")
(removelast
(apply #'concatenate 'string
(loop for item in thelist collect
(if (issymbolstring item)
"([^/]*)/"
(concatenate 'string item "/")))))
(when endswithslash "/")
"$"))
(symstobind (mapcar (lambda (item) (intern (string-upcase (subseq item 1)))) colonitems)))
`(list ,httpmethod ,theregex (quote ,symstobind) ,fntocall)))
(defmacro compile-routes (&rest routespecs)
`(list ,@(loop for routespec in routespecs collect
(apply #'routespec-compile routespec))))
(defun simple-router (request-uri request-type)
"takes in a request uri and type (:GET, :POST, etc...) and loops through all
compiled routes in *routeslist*. If it finds a route that matches
,it returns the associated handler and returns true. otherwise returns false"
(register-groups-bind (processed-uri) ("^([^?]*)\\??.*" request-uri)
(loop for compiled-route in *routeslist* do
(destructuring-bind (treqtype tregexp tvars tfntocall) compiled-route
(declare (ignore tvars))
(multiple-value-bind (regexmatch capturedstrings) (cl-ppcre:scan-to-strings tregexp processed-uri)
(declare (ignore regexmatch))
(if (and (not (eql capturedstrings nil))
(eql treqtype request-type))
(progn
(return-from simple-router (apply tfntocall (mapcar #'hunchentoot:url-decode (coerce capturedstrings 'list)))))))))))
(defmethod acceptor-dispatch-request ((acceptor simpleroutes-acceptor) request)
"The simple request dispatcher which tries to complete the request using simple,
but otherwise falls back to the hunchentoot defaults *dispatch-table* and easy-acceptor"
(let ((uri (request-uri request))
(request-type (hunchentoot:request-method request)))
(let* ((*routeslist* (let ((routes (routes acceptor)))
(typecase routes
(symbol (symbol-value routes))
(t routes))))
(potentialout (simple-router uri request-type)))
(or potentialout
(call-next-method)))))
(defmacro bind-alist-values (lambda-list alist-expression &rest body)
"this is intended to be used to access get and post parameters. example usage
(bind-alist-values (first second) (hunchentoot:get-parameters*)
(list first second))"
`(destructuring-bind ,lambda-list
(mapcar (lambda (varname)
(cdr (assoc (string varname)
,alist-expression
:test #'equalp)) )
(quote ,lambda-list))
,@body))
(defun lastitem (seq)
(let ((lindex (- (length seq) 1)))
(when (> lindex 0)
(elt seq lindex))))
pgcharts/README.md 0000644 0001750 0001750 00000010551 12376634355 014056 0 ustar vagrant vagrant # PostgreSQL Charts
## Screen Shots
It's intended as a visual project. Here's what it looks like.
### Query editing pane

### Chart pane

### Query listing pane

### Chart only pane
So that you can give an URL to just the chart for your coworkers to see (and
download as a PDF, PNG, JPEG or SVG document):

## Description
The *pgcharts* projects is a little web application that takes as input an
SQL query text and outputs its data in one of the following forms:
- HTML table
- Column Chart
- Bar Chart
- Pie Chart
- Donut Chart
With more to come (TODO):
- Area Chart
- Line Chart
- Stacked Area Chart
- Stacked Bar Chart
- Grouped Bar Chart
- CSV file
# Initial Setup
The *pgcharts* application needs its own PostgreSQL database to be able to
register user queries and their charts setup:
$ createdb pgcharts
$ pgcharts setup pgsql://localhost/pgcharts
Then you can start the service, which defaults to listening to
[http://localhost:9042/]():
$ pgcharts start
$ open http://localhost:9042/
Now, you can use *pgcharts* from your browser. Issue new query, save them
away, and see nice charts from their results!
# Registering databases
Once the *pgcharts* database has been created, it's necessary to
***register*** the database servers you want to run queries against:
$ pgcharts register pgsql://user:pass@host/dbname
$ pgcharts register pgsql://user:pass@host/seconddbname?sslmode=require
The *sslmode* option accepts the following values: `disable`, `allow`,
`prefer` and `require`. The `allow` and `prefer` options are implements in
the same way, translating to the
[Postmodern](https://marijnhaverbeke.nl/postmodern/postmodern.html)
PostgreSQL driver's value `:try`, where `:try` means *if the server supports
it*.
# Implementation
pgchart needs a database where to handle its own data, as it is storing a
list of database connections (where to run the queries) and a list of
queries (with a name and a tags list).
TODO: see about storing query results on the *pgcharts* database so that
it's possible to get back to them later. Maybe with some ways to run
the query again and compare?
# Security
The *pgcharts* web service offers no security implementation, no user role
management or privileges. To keep the service secure, users are only allowed
to query against *registered* database servers.
To register a database server to *pgcharts*, the command line interface must
be used, so only the service administrator is in a position to register new
database servers.
# Usage
pgcharts is a self-contained web application. As such, when you start the
command line application, it starts its own web server that you can connect
to.
# Install
The *pgcharts* application has been written in Common Lisp and uses a bunch
of librairies that are available through the *Quicklisp* distribution
system. The included `Makefile` cares about building a self-contained binary
for you, and can be used as following:
$
$ make
$ ./build/bin/pgcharts --help
Note that the self-contained binary also includes static web resources such
as *jquery*, *bootstrap*, *Highcharts* and *codemirror*.
## Build Dependencies
You need a recent enough [SBCL](http://sbcl.org/) Common Lisp compiler to be
able to compile pgcharts. It's easy to install on Linux, MacOSX and Windows.
debian$ sudo apt-get install sbcl
centos$ sudo yum install sbcl
macosx$ brew install sbcl
When using `debian stable` you might need to *backport* a recent enough
version of the compiler, because stable contains a very old version of it as
seen at [http://packages.debian.org/search?keywords=sbcl](). You will find
my backport at [http://pgsql.tapoueh.org/sbcl/]() to get you started
quickly, or apply the following recipe:
$
That's about it.
pgcharts/pgcharts.1.md 0000644 0001750 0001750 00000011044 12543560002 015050 0 ustar vagrant vagrant # pgcharts(1) -- PostgreSQL data loader
## SYNOPSIS
`pgcharts` [] []...
## DESCRIPTION
pgcharts is The PostgreSQL Extension Installer server.
## OPTIONS
* `-h`, `--help`:
Show command usage summary and exit.
* `-V`, `--version`:
Show pgcharts version string and exit.
* `-c`, `--config`:
Use the given configuration file (default to "~/.pgcharts.ini").
## COMMANDS
The pgcharts binary allows running and controling the pgcharts embedded web
server.
### CONFIGURATION CONTROL
While it's possible to ship a configuration file or to prepare it by hand,
the following commands allow to control the setup from the command line.
- `config [ name ] [ value ]`
Without arguments, print the whole configuration file content. When
given a variable *name*, print its current value. When given both a
*name* and a *value*, set the configuration variable to the given value.
- `config get `
Print the current value of the configuration variable *name*.
- `config set `
Set the variable *name* to the given *value*.
### SERVER CONTROL
The PostgreSQL Extension Installer comes with a PostgreSQL plugin that
downloads static files: that part doesn't need any server at all. This
server is meant to be used by maintainers of a set of extension archives,
when they want to ease the maintenance and setup of the building.
- `start`
Start the embedded pgcharts HTTP server on the port it's been setup to
listen to, which defaults to 8042. The
- `stop`
Stops the server.
- `status`
Print the result of querying the HTTP status API against the (hopefully)
running server.
- `pid`
Print the registered pid of the server process. This information might
be stale in case of unexpected termination of the server.
- `setup `
Connects to the PostgreSQL database specified with the *dburi* parameter
and install the database model there.
### REGISTERING DATABASES
Once pgcharts is properly setup (see the `setup` command above) then it's
necessary to add databases against which you want to run queries and draw
charts.
- `register `
Register given *dburi*.
## DATABASE URI
The *dburi* connection string is expected to be given as a *Connection URI*
as documented in the PostgreSQL documentation at
http://www.postgresql.org/docs/9.3/static/libpq-connect.html#LIBPQ-CONNSTRING.
postgresql://[user[:password]@][netloc][:port][/dbname][?sslmode=...]
Where:
- *user*
Can contain any character, including colon (`:`) which must then be
doubled (`::`) and at-sign (`@`) which must then be doubled (`@@`).
When omitted, the *user* name defaults to the value of the `PGUSER`
environment variable, and if it is unset, the value of the `USER`
environment variable.
- *password*
Can contain any character, including that at sign (`@`) which must then
be doubled (`@@`). To leave the password empty, when the *user* name
ends with at at sign, you then have to use the syntax user:@.
When omitted, the *password* defaults to the value of the `PGPASSWORD`
environment variable if it is set, otherwise the password is left
unset.
- *netloc*
Can be either a hostname in dotted notation, or an ipv4, or an Unix
domain socket path. Empty is the default network location, under a
system providing *unix domain socket* that method is preferred, otherwise
the *netloc* default to `localhost`.
It's possible to force the *unix domain socket* path by using the syntax
`unix:/path/to/where/the/socket/file/is`, so to force a non default
socket path and a non default port, you would have:
postgresql://unix:/tmp:54321/dbname
The *netloc* defaults to the value of the `PGHOST` environment
variable, and if it is unset, to either the default `unix` socket path
when running on a Unix system, and `localhost` otherwise.
- *dbname*
Should be a proper identifier (letter followed by a mix of letters,
digits and the punctuation signs comma (`,`), dash (`-`) and underscore
(`_`).
When omitted, the *dbname* defaults to the value of the environment
variable `PGDATABASE`, and if that is unset, to the *user* value as
determined above.
- The only optional parameter supported is `sslmode` and it accepts the
values `disable`, `allow`, `prefer` and `require`.
## AUTHOR
Dimitri Fontaine
## SEE ALSO
The pgcharts source code and all documentation may be downloaded from
.
pgcharts/Vagrantfile 0000644 0001750 0001750 00000001237 12404567210 014750 0 ustar vagrant vagrant # -*- mode: ruby -*-
# vi: set ft=ruby :
# Vagrantfile API/syntax version. Don't touch unless you know what you're doing!
VAGRANTFILE_API_VERSION = "2"
Vagrant.configure("2") do |config|
config.vm.box = "wheezy64"
config.vm.provision :file do |file|
file.source = 'vm-conf/devscripts'
file.destination = '/home/vagrant/.devscripts'
end
config.vm.provision :file do |file|
file.source = 'vm-conf/gpg.conf'
file.destination = '/home/vagrant/.gnupg/gpg.conf'
end
config.vm.provision "shell" do |s|
s.path = "vm-conf/bootstrap.sh"
s.privileged = false
end
config.vm.network :forwarded_port, guest: 9042, host: 9042
end
pgcharts/propaganda/ 0000755 0001750 0001750 00000000000 12376603062 014700 5 ustar vagrant vagrant pgcharts/propaganda/pgcharts-chart.png 0000644 0001750 0001750 00000466055 12376603021 020333 0 ustar vagrant vagrant ‰PNG
IHDR µ Æ Ô¨Ù
ÜiCCPICC Profile H
–wTSIÀï{©¤ÐH ½ Ò«ô@Aª`#$! %„ bW\*" ®èŠˆ‚kd-ˆ(¶E°÷YT”u±`Cå{Éîùηÿ}sÎÌüÞ;wîÌ»÷œ@{È‹3QU€,‘TÀœ•”Ì$=