This repository has been archived by the owner on Jun 22, 2019. It is now read-only.
-
-
Notifications
You must be signed in to change notification settings - Fork 10
/
module.lisp
285 lines (245 loc) · 12.6 KB
/
module.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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
#|
This file is a part of Colleen
(c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.colleen)
(defvar *bot-modules* (make-hash-table) "Global module table consisting of name->instance pairs.")
(defvar *current-module*)
(setf (documentation '*current-module* 'variable) "Special variable containing the module in the current module context.")
(defclass module ()
((%active :initform NIL :accessor active :allocation :class)
(%threads :initform (make-hash-table :test 'equalp) :accessor threads :allocation :class)
(%lock :initform (bt:make-recursive-lock) :accessor lock :allocation :class)
(%storage :initform (make-hash-table :test 'equal) :accessor storage :allocation :class))
(:documentation "Base module class."))
(defmacro generalize-module-accessor (name)
`(progn
(defmethod ,name ((module-name string))
(,name (get-module module-name)))
(defmethod ,name ((module-name symbol))
(,name (get-module module-name)))))
(generalize-module-accessor active)
(generalize-module-accessor threads)
(defmethod print-object ((module module) stream)
(print-unreadable-object (module stream)
(format stream "~a :threads ~d~:[~; :started~]"
(symbol-name (class-name (class-of module))) (active module) (hash-table-count (threads module))))
module)
(defgeneric start (module)
(:documentation "Start the module and activate it for use."))
(defmethod start ((module module))
module)
(defmethod start :around ((module module))
(load-storage module)
(call-next-method)
(setf (active module) T)
module)
(defgeneric stop (module)
(:documentation "Stop the module and attempt to clean everything up."))
(defmethod stop ((module module))
module)
(defmethod stop :around ((module module))
(setf (active module) NIL)
(loop for uid being the hash-keys of (threads module)
for thread being the hash-values of (threads module)
do (if (thread-alive-p thread)
(interrupt-thread thread #'(lambda () (error 'module-stop)))
(remhash uid (threads module))))
(call-next-method)
(save-storage module)
module)
(defmacro with-module-lock ((&optional (module '*current-module*) (lockvar (gensym "LOCK"))) &body forms)
"Creates a context with the module's lock held.
The FORMS are only executed once the lock has been acquired.
This is an implicit PROGN.
MODULE --- The module to use the lock of.
LOCKVAR --- A symbol the lock is bound to.
FORMS ::= form*"
`(let ((,lockvar (lock (get-module ,module))))
(bt:with-recursive-lock-held (,lockvar)
,@forms)))
(defun module-thread (module uuid)
"Returns the thread identified by UUID on MODULE or NIL if none is found."
(gethash uuid (threads (get-module module))))
(defgeneric (setf module-thread) (thread module uuid)
(:documentation "Sets the UUID on the module to the specified thread.
If a thread already exists at the specified UUID, a warning is logged."))
(defmethod (setf module-thread) (thread (module module) (uuid string))
(let* ((module (get-module module))
(threads (threads module)))
(when (gethash uuid threads)
(v:warn :module "Replacing ~a's already existing and potentially running thread ~a!" module uuid))
(with-module-lock (module)
(setf (gethash uuid threads)
thread))))
(defun stop-module-thread (module uuid)
"Stops the thread identified by UUID from the MODULE.
The thread will most likely remove itself once it stops.
It is not guaranteed that the thread will stop immediately."
(let ((thread (module-thread module uuid)))
(when (and thread (thread-alive-p thread))
(interrupt-thread thread #'(lambda () (error 'module-stop))))))
(defun remove-module-thread (module uuid &key keep-alive)
"Removes the thread identified by UUID from the MODULE.
If KEEP-ALIVE is non-NIL and the thread is alive, it is only removed.
Otherwise if it is still alive, the thread is stopped and removed."
(let* ((module (get-module module))
(thread (gethash uuid (threads module))))
(when thread
(when (and keep-alive (thread-alive-p thread))
(v:warn :module "Stopping ~a's thread ~a due to removal." module uuid)
(interrupt-thread thread #'(lambda () (error 'module-stop))))
(remhash uuid (threads module)))))
(defmacro with-module ((var &optional (name (get-current-module-name))) &body forms)
"Executes the forms in a context where VAR is bound to the module instance named by NAME.
This also binds *CURRENT-MODULE*."
`(let* ((,var (get-module ,name))
(*current-module* ,var))
,@forms))
(defmacro with-module-thread ((&optional (module '*current-module*)) &body thread-body)
"Executes the THREAD-BODY in a separate thread bound to the MODULE.
The return value of this is the new thread's UUID string.
The thread contains implicit condition handling constructs:
When an error is caught at the lowest level and *DEBUGGER* is non-NIL,
then the error is passed to INVOKE-DEBUGGER. If the condition is not
handled or when the thread body finishes executing, the thread is ended
and it is removed from the module's threads table."
(let ((uidgens (gensym "UUID"))
(modgens (gensym "MODULE"))
(modnamegens (gensym "MODULE-NAME")))
`(let* ((,uidgens (princ-to-string (uuid:make-v4-uuid)))
(,modgens (get-module ,module))
(,modnamegens (name ,modgens)))
(setf (module-thread ,modgens ,uidgens)
(make-thread #'(lambda ()
(unwind-protect
(handler-case
(handler-bind
((error #'(lambda (err)
(v:severe ,modnamegens "Unexpected error at thread-level: ~a" err)
(when *debugger*
(invoke-debugger err)))))
,@thread-body)
(error (err)
(declare (ignore err)))
(module-stop (err)
(declare (ignore err))
(v:debug ,modnamegens "Received module-stop condition, leaving thread ~a." ,uidgens)))
(v:trace ,modnamegens "Ending thread ~a." ,uidgens)
(with-module-lock (,modgens)
(remhash ,uidgens (threads ,modgens)))))
:initial-bindings (loop for symbol in '(*current-server* *current-module* uc:*config*)
when (boundp symbol)
collect (cons symbol (symbol-value symbol)))))
,uidgens)))
(defun print-module-thread-stats ()
"Prints all modules that have recorded threads and whether the threads are active (.) or dead (x)."
(loop for v being the hash-values of *bot-modules*
when (< 0 (hash-table-count (threads v)))
do (format T "~25a ~4a " v (hash-table-count (threads v)))
(loop for tv being the hash-values of (threads v)
do (format T "~:[x~;.~]" (bt:thread-alive-p tv)))
(format T "~%")))
(defun sweep-module-threads (module)
"Sweeps the module's threads table and removes all dead threads.
Returns two values: how many threads were removed and how many remain."
(let* ((module (get-module module))
(threads (threads module))
(count 0))
(with-module-lock (module)
(loop for k being the hash-keys of threads
for v being the hash-values of threads
unless (thread-alive-p v)
do (remhash k threads)
(incf count))
(let ((remaining (hash-table-count threads)))
(v:debug (name module) "Sweeped threads. ~d removed, ~d still active." count remaining)
(values count remaining)))))
(defun sweep-all-module-threads ()
"Performs SWEEP-MODULE-THREADS on all modules."
(loop for v being the hash-values of *bot-modules*
summing (sweep-module-threads v)))
(defgeneric to-module-name (name-object)
(:documentation "Attempts to transform the given object into the keyword name for a module.")
(:method ((module-instance module))
(to-module-name (princ-to-string (class-name (class-of module-instance)))))
(:method ((module-name string))
(find-symbol (string-upcase module-name) :KEYWORD))
(:method ((module-name symbol))
(if (keywordp module-name)
module-name
(to-module-name (symbol-name module-name)))))
(defun get-module (designator)
"Returns the current class instance of the module."
(gethash (to-module-name designator) *bot-modules*))
(defun module (designator)
(get-module designator))
(defgeneric (setf module) (instance designator)
(:documentation "Assign a new module instance to a module designator."))
(defmethod (setf module) (instance designator)
(setf (gethash (to-module-name designator) *bot-modules*) instance))
(defmethod name ((module module))
(find-symbol (princ-to-string (class-name (class-of module))) :KEYWORD))
(defun package-symbol (package)
"Returns the symbol of a package."
(let ((name (package-name package)))
(or (find-symbol name "KEYWORD")
(intern name "KEYWORD"))))
(defun get-current-module (&optional (package *package*))
"Returns the module of the current package context."
(get-module (get (package-symbol package) :module)))
(defun get-current-module-name (&optional (package *package*))
"Returns the name of the module in the current package context."
(get (package-symbol package) :module))
(defmacro define-module (name direct-superclasses direct-slots &body options)
"Define a new module class. See DEFCLASS.
Note that all module slots are always allocated on the class."
(let ((keyname (intern (string-upcase name) "KEYWORD")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,name (module ,@direct-superclasses)
((%active :initform NIL :reader active :allocation :class)
(%threads :initform (make-hash-table :test 'equalp) :accessor threads :allocation :class)
(%lock :initform (bt:make-recursive-lock ,(string name)) :accessor lock :allocation :class)
(%storage :initform (make-hash-table :test 'equal) :accessor storage :allocation :class)
,@(mapcar #'(lambda (slot) (append slot '(:allocation :class))) direct-slots))
,@options)
(when (and (gethash ,keyname *bot-modules*)
(active (gethash ,keyname *bot-modules*)))
(v:warn :colleen "Redefining started module ~a. Let's hope everything goes well..." ,keyname))
(setf (get (package-symbol *package*) :module) ,keyname
(gethash ,keyname *bot-modules*) (make-instance ',name)))))
(defun start-module (&rest module-names)
"Start up one or more modules. Each module name should be a symbol or string.
The following restarts are available:
SKIP --- Skip starting the module.
FORCE --- Force starting even though it's already active.
RETRY --- Simply retry starting."
(dolist (module-name module-names)
(setf module-name (to-module-name module-name))
(with-simple-restart (skip "Skip starting ~a." module-name)
(let ((module (get-module module-name)))
(assert (not (null module)) () "Module ~a not found!" module-name)
(with-simple-restart (force "Force starting the module.")
(assert (not (active module)) () "Module ~a already started!" module-name))
(v:info module-name "Starting...")
(loop until (with-simple-restart (retry "Retry starting ~a." module-name)
(start module)))
module))))
(defun stop-module (&rest module-names)
"Stop one or more modules. Each module name should be a symbol or string.
The following restarts are available:
SKIP --- Skip stopping the module.
FORCE --- Force stopping even though it isn't active.
RETRY --- Simply retry stopping."
(dolist (module-name module-names)
(setf module-name (to-module-name module-name))
(with-simple-restart (skip "Skip stopping ~a." module-name)
(let ((module (get-module module-name)))
(assert (not (null module)) () "Module ~a not found!" module-name)
(with-simple-restart (force "Force stopping ~a." module-name)
(assert (not (not (active module))) () "Module ~a already stopped!" module-name))
(v:info module-name "Stopping...")
(loop until (with-simple-restart (retry "Retry stopping ~a." module-name)
(stop module)))
module))))