A WhatsApp (Web) transport for XMPP.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

96 lines

  1. (in-package :whatsxmpp)
  2. (defvar *db* nil
  3. "Connection to the database.")
  4. (defvar *db-lock* (bt:make-recursive-lock "sqlite3 lock")
  5. "Lock for *DB*.")
  6. (defparameter *default-database-path* "data.sqlite3"
  7. "Default path to the SQLite database file.")
  8. (defvar *prepared-statements* nil
  9. "List of statements prepared by PREPARED-STATEMENT.")
  10. (defparameter *sqlite-pragmas*
  11. '("PRAGMA journal_mode = WAL"
  12. "PRAGMA foreign_keys = ON"
  13. "PRAGMA synchronous = NORMAL")
  14. "List of SQLite pragmas to run on connection to make things bearable")
  15. (defun run-pragmas ()
  16. "Runs all statements in *SQLITE-PRAGMAS*."
  17. (mapc (lambda (x) (sqlite:execute-non-query *db* x)) *sqlite-pragmas*))
  18. (defun connect-database (&optional (path *default-database-path*))
  19. "Establish a connection to the database."
  20. (bt:with-recursive-lock-held (*db-lock*)
  21. (setf *db* (sqlite:connect path))
  22. (run-pragmas)
  23. (loop for sym in *prepared-statements*
  24. do (eval `(setf ,sym nil)))
  25. (setf *prepared-statements* nil)))
  26. (defmacro with-transaction (&body forms)
  27. `(bt:with-recursive-lock-held (*db-lock*)
  28. (sqlite:with-transaction *db*
  29. ,@forms)))
  30. (defmacro prepared-statement (statement)
  31. "Caches the creation of a prepared statement with SQL text STATEMENT.
  32. In other words, prepares STATEMENT once, then returns the prepared statement after that instead of doing that work again."
  33. (let ((statement-sym (gensym "PREPARED-STATEMENT-")))
  34. (eval `(defvar ,statement-sym nil))
  35. `(progn
  36. (defvar ,statement-sym nil)
  37. (unless ,statement-sym
  38. (setf ,statement-sym (sqlite:prepare-statement *db* ,statement))
  39. (setf *prepared-statements* (cons ',statement-sym *prepared-statements*)))
  40. ,statement-sym)))
  41. (defmacro with-prepared-statement ((name statement) &body forms)
  42. "Evaluates FORMS, binding a prepared statement with SQL text STATEMENT to NAME and making sure it is reset beforehand."
  43. `(bt:with-recursive-lock-held (*db-lock*)
  44. (let ((,name (prepared-statement ,statement)))
  45. (sqlite:reset-statement ,name)
  46. (sqlite:clear-statement-bindings ,name)
  47. ,@forms)))
  48. (defmacro with-prepared-statements (statements &body forms)
  49. "Like WITH-PREPARED-STATEMENT, but takes multiple statements."
  50. (let ((let-forms (loop for (name statement) in statements
  51. collect `(,name (prepared-statement ,statement))))
  52. (reset-forms (loop for (name statement) in statements
  53. collect `(progn
  54. (sqlite:reset-statement ,name)
  55. (sqlite:clear-statement-bindings ,name)))))
  56. `(bt:with-recursive-lock-held (*db-lock*)
  57. (let (,@let-forms)
  58. ,@reset-forms
  59. ,@forms))))
  60. (defmacro column-values (statement)
  61. "Returns the values in the current row of the STATEMENT."
  62. (let ((i-sym (gensym))
  63. (stmt (gensym)))
  64. `(let ((,stmt ,statement))
  65. (loop
  66. for ,i-sym from 0 below (length (sqlite:statement-column-names ,stmt))
  67. collect (sqlite:statement-column-value ,stmt ,i-sym)))))
  68. (defmacro with-bound-columns (parameters statement &body forms)
  69. "Binds each column value of STATEMENT to the symbols in PARAMETERS, and runs FORMS."
  70. (let ((let-forms (loop
  71. for param in parameters
  72. for idx from 0 upto (1- (length parameters))
  73. collect `(,param (sqlite:statement-column-value ,statement ,idx)))))
  74. `(let (,@let-forms) ,@forms)))
  75. (defmacro bind-parameters (statement &rest parameters)
  76. "Binds PARAMETERS to the prepared statement STATEMENT.
  77. PARAMETERS are either simple values (in which case they're bound to parameters 1, 2, ...),
  78. or cons cells, where the `car` is the index to bind to and the `cdr' is the value to use."
  79. `(progn
  80. ,@(loop for param in parameters
  81. for idx from 1 upto (length parameters)
  82. collect (if (listp param)
  83. `(sqlite:bind-parameter ,statement ,(car param) ,(second param))
  84. `(sqlite:bind-parameter ,statement ,idx ,param)))))