-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
transaction.lisp
92 lines (79 loc) · 2.92 KB
/
transaction.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
;; cl-facts
;; Copyright 2011, 2023 Thomas de Grivel <thodg@kmx.io>
;;
;; Permission is hereby granted to use this software granted
;; the above copyright notice and this permission paragraph
;; are included in all copies and substantial portions of this
;; software.
;;
;; THIS SOFTWARE IS PROVIDED "AS-IS" WITHOUT ANY GUARANTEE OF
;; PURPOSE AND PERFORMANCE. IN NO EVENT WHATSOEVER SHALL THE
;; AUTHOR BE CONSIDERED LIABLE FOR THE USE AND PERFORMANCE OF
;; THIS SOFTWARE.
(in-package :facts)
;; Transactions
(defvar *transaction* nil)
(defvar *db-path* nil)
(defvar *db-path-defaults* (make-pathname :type "facts"))
(defvar *db-log-path-defaults* (make-pathname :type "facts-log"))
(defvar *transaction-vars* nil)
(defvar *transaction-lock* (bordeaux-threads:make-lock))
(defun transaction-var (value name)
(let ((cell (rassoc name *transaction-vars* :test #'eq)))
(if cell
(setf (car cell) value)
(push (cons value name) *transaction-vars*))))
(defun transaction-vars ()
*transaction-vars*)
(defstruct transaction
(completed nil :type (member nil t))
(log () :type list))
(defmacro log-transaction-operation (op &rest args)
(unless (rollback-function op)
(warn "Undefined rollback function for ~S" op))
`(when *transaction*
(push (list ',op ,@args)
(transaction-log *transaction*))))
(defun db-path ()
(and *db-path*
(merge-pathnames *db-path* *db-path-defaults*)))
(defun db-log-path ()
(and *db-path*
(merge-pathnames *db-path* *db-log-path-defaults*)))
(defun commit-transaction (tx)
(let ((path (db-log-path)))
(when path
(ensure-directories-exist path)
(with-open-file (out path
:direction :output
:if-exists :append
:if-does-not-exist :create)
(dolist (operation (reverse (transaction-log tx)))
(write (sublis (transaction-vars) operation)
:stream out
:readably t
:pretty nil)
(fresh-line out)))))
(setf (transaction-completed tx) t))
(defun rollback-transaction (tx)
(dolist (operation (transaction-log tx))
(apply #'rollback operation)))
(defmacro with-mutex ((mutex) &body body)
(let ((g!mutex (gensym "MUTEX-"))
(g!result (gensym "RESULT-")))
`(let ((,g!mutex ,mutex)
,g!result)
(if (bordeaux-threads:with-lock-held (,g!mutex)
(setf ,g!result (progn ,@body))
t)
,g!result
(error "Could not acquire ~S." ,g!mutex)))))
(defmacro with-transaction (&body body)
`(if *transaction*
(progn ,@body)
(with-mutex (*transaction-mutex*)
(let ((*transaction* (make-transaction)))
(unwind-protect (prog1 (progn ,@body)
(commit-transaction *transaction*))
(unless (transaction-completed *transaction*)
(rollback-transaction *transaction*)))))))