chatikbot/db.lisp

(in-package :cl-user)
(defpackage chatikbot.db
  (:use :cl)
  (:import-from :chatikbot.utils
                :dekeyify)
  (:export :db-transaction
           :db-execute
           :db-select
           :db-single
           :db-init
           :load-settings
           :set-setting
           :lists-set-entry
           :lists-get))
(in-package :chatikbot.db)

(defvar *db-name* "db.sqlite" "SQLite database name")

(defun db-path ()
  (merge-pathnames *db-name*
                   (asdf:component-pathname
                    (asdf:find-system '#:chatikbot))))

(defvar *current-db* nil "Currently opened database")
(defvar *db-lock* (bordeaux-threads:make-recursive-lock
                   "sqlite connection lock") "Database connection lock")
(defmacro with-db ((db) &body body)
  `(bordeaux-threads:with-recursive-lock-held (*db-lock*)
     (unless *current-db*
       (let ((path (db-path)))
         (log:info "Connecting to ~A" path)
         (setf *current-db* (sqlite:connect path))
         (sqlite:execute-non-query *current-db* "PRAGMA foreign_keys = ON")))
     (let ((,db *current-db*))
       (declare (ignorable ,db))
       (handler-case (progn ,@body)
         (sqlite:sqlite-error (e)
           (log:error (sqlite:sqlite-error-code e)
                      (sqlite:sqlite-error-message e))
           (ignore-errors (sqlite:disconnect *current-db*))
           (setf *current-db* nil)
           (error e))))))

(defmacro db-transaction (&body body)
  (let ((db (gensym "DB-")))
    `(with-db (,db)
       (sqlite:with-transaction ,db ,@body))))

(defun db-execute (sql &rest parameters)
  (with-db (db)
    (apply #'sqlite:execute-non-query db sql parameters)
    (sqlite:last-insert-rowid db)))

(defun db-select (sql &rest parameters)
  (with-db (db)
    (apply #'sqlite:execute-to-list db sql parameters)))

(defun db-single (sql &rest parameters)
  (with-db (db)
    (apply #'sqlite:execute-single db sql parameters)))

(defun db-init ()
  (with-db (db)
    (db-execute "create table if not exists settings (var, val)")
    (db-execute "create unique index if not exists settings_var_unique on settings (var)")
    (db-execute "create table if not exists lists (list, entry)")
    (db-execute "create unique index if not exists lists_unique on lists (list, entry)")))

(defun load-settings ()
  (let ((*package* (find-package :chatikbot)))
    (loop for (var val) in (db-select "select var, val from settings")
       do (handler-case (setf (symbol-value (read-from-string var))
                              (read-from-string val))
            (error (e) (log:error "~A" e))))))

(defun set-setting (symbol value)
  (handler-case
      (let ((*package* (find-package :chatikbot)))
        (db-execute "replace into settings (var, val) values (?, ?)"
                    (write-to-string symbol)
                    (write-to-string value))
        (setf (symbol-value symbol) value))
    (error (e) (log:error e))))

(defun lists-set-entry (list entry &optional (add t))
  (with-db (db)
    (handler-case
        (if add
            (db-execute "insert into lists (list, entry) values (?, ?)"
                        (dekeyify list) entry)
            (db-execute "delete from lists where list = ? and entry = ?"
                        (dekeyify list) entry))
      (sqlite:sqlite-constraint-error ()
        nil))))

(defun lists-get (list)
  (with-db (db)
    (mapcar #'car (db-select "select entry from lists where list = ?" (dekeyify list)))))