feedbot.lisp 1 ;;;; feedbot.lisp
2
3 (in-package :feedbot)
4
5 (defvar *check-freq* 60)
6 (defvar *announce-freq* 60)
7 (defvar *max-sent-msgs* 100)
8 (defvar *announce-delay* 1)
9
10 ;; A feedbot is a trilemabot with the following additional fields:
11 ;;
12 ;; - a feed db
13 ;; - a message queue
14 ;; - a mutex to protect concurrent feed db accesses
15 ;; - a mutex to protect concurrent message queue accesses
16 ;; - a thread that periodically updates the feed db
17 ;; - a thread that periodically pushes new entries to the message queue
18 (defclass feedbot (trilemabot)
19 ((feed-db :accessor feedbot-feed-db :initform nil)
20 (msg-queue :accessor feedbot-msg-queue :initform nil)
21 (db-mutex :accessor feedbot-db-mutex
22 :initform (make-mutex :name "feedbot-db-mutex"))
23 (queue-mutex :accessor feedbot-queue-mutex
24 :initform (make-mutex :name "feedbot-queue-mutex"))
25 (checker-thread :accessor feedbot-checker-thread :initform nil)
26 (announcer-thread :accessor feedbot-announcer-thread :initform nil)))
27
28 ;; I. The feed db
29 ;; --------------
30 ;;
31 ;; Feedbot operation is centered around a data structure that I've so
32 ;; pompously called a "feed database" (or feed db).
33 ;;
34 ;; A feed db is a list of feeds.
35 ;;
36 ;; A feed is a list of the form:
37 ;;
38 ;; (url :title title :entries entries :rcpts rcpts)
39 ;;
40 ;; where url and title are strings, entries is a list of entries, rcpts
41 ;; is a list of recipients.
42 ;;
43 ;; An entry is a list of the form:
44 ;;
45 ;; (entry :id id :title title :link url)
46 ;;
47 ;; where entry is the symbol ENTRY; id, title and url are strings. Note
48 ;; that in practice, id and url often (but not always) match.
49 ;;
50 ;; A recipient is a string denoting a nick who will receive new entries
51 ;; when they are added to the database.
52
53 ;; II. Feed db manipulation
54 ;; ------------------------
55 ;;
56 ;; Functionality pertaining to the feed db is split into the following
57 ;; categories:
58 ;;
59 ;; a. "Low-level" functions operating on the feed db, feeds, entries and
60 ;; recipients; examples include setting the title of a feed, adding
61 ;; entries or searching for a recipient.
62 ;;
63 ;; b. A macro, `with-feed-db', providing a thread-safe context for feed
64 ;; db processing; see notes below for further details.
65 ;;
66 ;; c. Interface, or "high-level" methods to be called by e.g. the bot
67 ;; operator or by the IRC-facing code. These typically bear the
68 ;; following form:
69 ;;
70 ;; (defmethod feedbot-... ((bot feedbot) arg1 arg2 ...)
71 ;; ...)
72
73 ;; *Note*: feedbot operates in a concurrent environment, where multiple
74 ;; threads may access the feed db at a given time; for example, the feed
75 ;; checker and SBCL's shell. Thus, all (c) functions are implemented in
76 ;; terms of (a), and furthermore, they use (b) in order to ensure
77 ;; thread-safety. We distinguish between thread-safe and unsafe
78 ;; functions by employing the following convention:
79 ;;
80 ;; Feed db functions whose name end in ! (also named below
81 ;; !-functions) are thread unsafe and should be used *only* in
82 ;; conjunction with the db-mutex or `with-feed-db'.
83
84 ;; *Note*: the feed db should also reside on a persistent medium. This
85 ;; functionality will be implemented later.
86
87 ;; -- a. Low-level functions
88 ;;
89 ;; a.1. Entry and recipient manipulation.
90 (defun make-entry (id title link)
91 (list 'entry :id id :title title :link link))
92
93 (defun entry-p (entry)
94 (and (eq (car entry) 'entry)
95 (stringp (getf (cdr entry) :id))
96 (stringp (getf (cdr entry) :title))
97 (stringp (getf (cdr entry) :link))))
98
99 (defun get-entry-id (entry)
100 (assert (entry-p entry))
101 (getf (cdr entry) :id))
102
103 (defun get-entry-title (entry)
104 (assert (entry-p entry))
105 (getf (cdr entry) :title))
106
107 (defun get-entry-link (entry)
108 (getf (cdr entry) :link))
109
110 (defun channel-rcpt-p (rcpt)
111 ;; Both channel names and nicknames must contain at least one
112 ;; character, as per RFC 1459.
113 (assert (> (length rcpt) 0))
114 (let ((prefix (char rcpt 0)))
115 (find prefix '(#\# #\&) :test #'char=)))
116
117 (defun nickname-rcpt-p (rcpt)
118 (not (channel-rcpt-p rcpt)))
119
120 ;; a.2. Feed (db) manipulation.
121 (defun make-feed (feed-id &key title entries rcpts)
122 (list feed-id :title title :entries entries :rcpts rcpts))
123
124 (defun lookup-feed! (feed-id feed-db)
125 (assoc feed-id feed-db :test #'string=))
126
127 (defun get-feed-id! (feed)
128 (car feed))
129
130 (defun get-feed-title! (feed)
131 (getf (cdr feed) :title))
132
133 (defun get-feed-entries! (feed)
134 (getf (cdr feed) :entries))
135
136 (defun get-feed-rcpts! (feed)
137 (getf (cdr feed) :rcpts))
138
139 (defun set-feed-title! (feed title)
140 (setf (getf (cdr feed) :title) title))
141
142 (defun push-entry-to-feed! (feed entry)
143 (push entry (getf (cdr feed) :entries)))
144
145 (defun find-entry-in-feed! (feed entry-id)
146 (find entry-id (get-feed-entries! feed)
147 :key #'get-entry-id
148 :test #'string=))
149
150 (defun push-rcpt-to-feed! (feed rcpt)
151 (push rcpt (getf (cdr feed) :rcpts)))
152
153 (defun find-rcpt-in-feed! (feed rcpt)
154 (find rcpt (get-feed-rcpts! feed)
155 :test #'string=))
156
157 (defun delete-rcpt-from-feed! (feed rcpt)
158 (setf (getf (cdr feed) :rcpts)
159 (delete rcpt (get-feed-rcpts! feed)
160 :test #'string=)))
161
162 ;; a.3. Feed (db) manipulation of the beefier kind.
163 ;;
164 ;; These are typically used by the feed checker to efficiently keep the
165 ;; feed db in sync with remote content.
166 (defun delete-stale-entries-in-feed! (feed entries)
167 "Delete the entries in `feed' that are not in `entries'."
168 (let ((feed-entries (get-feed-entries! feed)))
169 (setf (getf (cdr feed) :entries)
170 (delete-if-not #'(lambda (entry)
171 (member (get-entry-id entry) entries
172 :key #'get-entry-id
173 :test #'string=))
174 feed-entries))))
175
176 (defun update-feed! (feed)
177 "Grab the contents of `feed' from remote URL and update.
178
179 Returns entries that previously didn't exist in feed. Entries that no
180 longer exist in the remote feed are removed."
181 (let* ((feed-id (get-feed-id! feed))
182 (fp-feed (try-parse-feed feed-id))
183 (fp-feed-title (when fp-feed
184 (sanitize-string (feed-title fp-feed))))
185 (fp-feed-items (when fp-feed
186 (feed-items fp-feed))))
187 ;; Check that we actually have a feed
188 (when (not fp-feed)
189 (return-from update-feed! nil))
190 ;; Convert entries to our format
191 (let ((entries (loop for item in fp-feed-items
192 for id = (or (item-id item)
193 (item-link item))
194 for title = (item-title item)
195 for link = (item-link item)
196 until (or (null title) (null link))
197 collect (make-entry (sanitize-string id)
198 (sanitize-string title)
199 (sanitize-string link))))
200 (new-entries nil))
201 ;; Set feed title
202 (set-feed-title! feed fp-feed-title)
203 ;; Add new entries and keep track of them. Make messages to
204 ;; forward downstream to announcer.
205 (loop for entry in entries do
206 (when (not (find-entry-in-feed! feed
207 (get-entry-id entry)))
208 (push-entry-to-feed! feed entry)
209 (loop for rcpt in (get-feed-rcpts! feed) do
210 (push (make-msg rcpt nil feed-id fp-feed-title entry)
211 new-entries))))
212 ;; Delete old entries
213 (delete-stale-entries-in-feed! feed entries)
214 ;; Return new entries
215 new-entries)))
216
217 ;; -- b.
218 (defmacro with-feed-db ((feed-db) bot &body body)
219 "Execute code within the thread-safe `feed-db' scope of `bot'."
220 (with-gensyms (db-mutex)
221 `(with-slots ((,feed-db feed-db) (,db-mutex db-mutex))
222 ,bot
223 (with-mutex (,db-mutex)
224 ,@body))))
225
226 ;; -- c. Feed db interface methods
227 ;;
228 ;; c.1. General functionality on feeds.
229 (defmethod feedbot-get-or-create-feed ((bot feedbot) feed-id &optional rcpts)
230 "Get feed with id `feed-id' from the feed db of `bot'.
231
232 If `feed-id' doesn't point to a feed, a new feed with that id is created
233 and inserted into the feed db.
234
235 Optionally, newly-created feeds may be initialized with a list of
236 `rcpts'."
237 (with-feed-db (feed-db) bot
238 (let ((feed (lookup-feed! feed-id feed-db)))
239 ;; If feed doesn't exist
240 (when (not feed)
241 (setq feed (make-feed feed-id :rcpts rcpts))
242 (push feed feed-db))
243 feed)))
244
245 (defmethod feedbot-delete-feed ((bot feedbot) feed-id)
246 "Destructively remove feed `feed-id' from the feed db of `bot'.
247
248 The operation has no effect if id `feed-id' doesn't exist."
249 (with-feed-db (feed-db) bot
250 (setf feed-db (delete feed-id feed-db
251 :key #'car
252 :test #'string=))))
253
254 (defmethod feedbot-add-rcpts ((bot feedbot) feed-id &rest rcpts)
255 "Add recipient to feed `feed-id' in `bot'."
256 (with-feed-db (feed-db) bot
257 (let ((feed (lookup-feed! feed-id feed-db)))
258 (assert feed)
259 (loop for rcpt in rcpts do
260 (when (not (find-rcpt-in-feed! feed rcpt))
261 (push-rcpt-to-feed! feed rcpt)))
262 (get-feed-rcpts! feed))))
263
264 (defmethod feedbot-remove-rcpt ((bot feedbot) feed-id rcpt)
265 "Remove recipient to feed `feed-id' in `bot'."
266 (with-feed-db (feed-db) bot
267 (let ((feed (lookup-feed! feed-id feed-db)))
268 (assert feed)
269 (delete-rcpt-from-feed! feed rcpt))))
270
271 (defmethod feedbot-select-feeds ((bot feedbot)
272 &key (fields nil) (where #'identity))
273 "Select `fields' from feed db of `bot', for which the predicate
274 `where' holds.
275
276 Valid fields are: :ID, :TITLE, :ENTRIES and :RCPTS."
277 (flet ((selector-func (field)
278 (ecase field
279 (:id #'get-feed-id!)
280 (:title #'get-feed-title!)
281 (:entries #'get-feed-entries!)
282 (:rcpts #'get-feed-rcpts!))))
283 (with-feed-db (feed-db) bot
284 (let ((whered (remove-if-not where feed-db)))
285 (mapcar #'(lambda (feed)
286 (mapcar #'(lambda (field)
287 (funcall (selector-func field) feed))
288 fields))
289 whered)))))
290
291 (defmethod feedbot-list-feeds ((bot feedbot))
292 "List feed ids in the feed db of `bot'."
293 (mapcar #'car
294 (feedbot-select-feeds bot :fields '(:id))))
295
296 ;; c.2. Feed checking methods.
297 (defmethod feedbot-update-feed ((bot feedbot) feed-id)
298 "Update `feed-id' in the feed db of `bot'."
299 (with-feed-db (feed-db) bot
300 (let ((feed (lookup-feed! feed-id feed-db)))
301 (if feed
302 (update-feed! feed)
303 (error "Feed ~a not found." feed-id)))))
304
305 (defmethod feedbot-update-feed-db ((bot feedbot))
306 "Update all the feeds in the feed db of `bot'."
307 (with-feed-db (feed-db) bot
308 (loop for feed in feed-db
309 append (update-feed! feed))))
310
311 ;; III. The feed checker
312 ;; ---------------------
313 ;;
314 ;; The feed checker runs on a so-called "checker thread", that
315 ;; periodically (see `*check-freq*') runs the feed db update
316 ;; code. Additionally, the feed checker delegates new (previously
317 ;; unseen) entries to a so-called "announcer".
318 ;;
319 ;; To test feedbot feed checker functionality, simply run:
320 ;;
321 ;; > (defvar *feedbot*
322 ;; (make-instance 'feedbot:feedbot))
323 ;; > (feedbot:feedbot-start-checker-thread *feedbot*)
324 ;; > (feedbot:feedbot-get-or-create-feed
325 ;; *feedbot* "http://thetarpit.org/rss.xml")
326 (defun checker-thread (bot)
327 "A loop that should endlessly check for feeds."
328 (loop do
329 ;; Wait for a while
330 (sleep *check-freq*)
331 ;; Check for new entries and send messages to announcer.
332 (let ((new (feedbot-update-feed-db bot)))
333 (apply #'feedbot-pushnew-to-msg-queue bot new))
334 ;; Save feedbot state
335 (feedbot-save-state bot)))
336
337 (defmethod feedbot-start-checker-thread ((bot feedbot))
338 "Start feed checker loop for `bot'."
339 (with-slots (checker-thread) bot
340 (assert (or (null checker-thread)
341 (and (eql (type-of checker-thread) 'thread)
342 (not (thread-alive-p checker-thread)))))
343 (setf checker-thread
344 (make-thread
345 #'checker-thread
346 :name "feedbot-checker-thread"
347 :arguments (list bot)))))
348
349 (defmethod feedbot-stop-checker-thread ((bot feedbot))
350 "Stop feed checker loop for `bot'."
351 (with-slots (checker-thread) bot
352 (terminate-thread checker-thread)
353 (setf checker-thread nil)))
354
355 ;; IV. The message queue
356 ;; ---------------------
357 ;;
358 ;; Once new feed entries are found by the feed checker, they are to be
359 ;; distributed to the recipient(s) via e.g. IRC messages. We decouple
360 ;; feed checking and announcements by introducing a specialized
361 ;; producer-consumer data structure, the message queue.
362 ;;
363 ;; A message queue is a list of messages.
364 ;;
365 ;; A message is a list of the form:
366 ;;
367 ;; (msg :to rcpt :sent sent
368 ;; :feed-id feed-id :feed-title feed-title :entry entry)
369 ;;
370 ;; where: msg is the symbol MSG; rcpt is a string denoting a recipient;
371 ;; sent is a boolean that, when set to true, marks the message as sent;
372 ;; feed-id is a string denoting the feed id of the entry's associated
373 ;; feed; feed-title is the title of the feed; and entry is a new entry.
374 ;;
375 ;; *Note*: feed-title is an optimization which saves the announcer an
376 ;; extra feed db lookup when the message is sent. See below for more
377 ;; details.
378
379 ;; V. Message queue manipulation
380 ;; -----------------------------
381 ;;
382 ;; There are three fundamental operations on message queues: pushing new
383 ;; messages, retrieving messages and deleting sent messages.
384 ;;
385 ;; As in the case of the feed db: a. low-level operations; b. used in
386 ;; conjunction with `with-msg-queue'; c. are used to implement the
387 ;; functionality described above.
388
389 ;; -- a. Low-level functions
390 (defun make-msg (to sent feed-id feed-title entry)
391 (list 'msg
392 :to to :sent sent
393 :feed-id feed-id :feed-title feed-title
394 :entry entry))
395
396 (defun get-msg-to! (msg)
397 (getf (cdr msg) :to))
398
399 (defun get-msg-sent! (msg)
400 (getf (cdr msg) :sent))
401
402 (defun get-msg-feed-id! (msg)
403 (getf (cdr msg) :feed-id))
404
405 (defun get-msg-feed-title! (msg)
406 (getf (cdr msg) :feed-title))
407
408 (defun get-msg-entry! (msg)
409 (getf (cdr msg) :entry))
410
411 (defun set-msg-sent! (msg &optional (sent t))
412 (setf (getf (cdr msg) :sent) sent))
413
414 (defmacro push-msg-to-queue! (queue msg)
415 `(push ,msg ,queue))
416
417 (defun delete-msgs-from-queue-if! (queue pred)
418 (delete-if pred queue))
419
420 ;; -- b.
421 (defmacro with-msg-queue ((queue) bot &body body)
422 "Execute code within the thread-safe `msg-queue' scope of `bot'."
423 (with-gensyms (queue-mutex)
424 `(with-slots ((,queue msg-queue) (,queue-mutex queue-mutex))
425 ,bot
426 (with-mutex (,queue-mutex)
427 ,@body))))
428
429 ;; -- c. Message queue methods
430 (defmethod feedbot-process-msg-queue ((bot feedbot) func)
431 "Process messages in the msg queue `bot' accoding to `func'.
432
433 Returns the updated message queue."
434 (with-msg-queue (msg-queue) bot
435 (loop for msg in msg-queue do
436 (funcall func msg))
437 msg-queue))
438
439 (defmethod feedbot-pushnew-to-msg-queue ((bot feedbot) &rest msgs)
440 "Push new messages to the msg queue of `bot'.
441
442 Returns the updated message queue."
443 (with-msg-queue (msg-queue) bot
444 (loop for msg in msgs do
445 (push-msg-to-queue! msg-queue msg))
446 msg-queue))
447
448 (defmethod feedbot-delete-sent-msgs ((bot feedbot))
449 "Delete sent messages from the msg queue of `bot'.
450
451 Returns the updated message queue."
452 (with-msg-queue (msg-queue) bot
453 (setf msg-queue (delete-msgs-from-queue-if! msg-queue
454 #'get-msg-sent!))
455 msg-queue))
456
457 ;; VI. The entry announcer
458 ;; -----------------------
459 ;;
460 ;; The entry announcer periodically scans the message queue for new
461 ;; (unsent) messages from the feed checker and announces the associated
462 ;; entries, i.e. sends them to the recipient.
463 ;;
464 ;; Additionally, if the number of sent messages is over a certain
465 ;; threshold (see `*max-sent-msgs*'), then they are garbage
466 ;; collected. To eliminate this check, set `*max-sent-msgs*' to NIL.
467 (defun announce-stdout! (msg)
468 (let ((entry (get-msg-entry! msg)))
469 (format *standard-output*
470 "[fdb] To: ~a~% ~a << ~a -- ~a~%"
471 (get-msg-to! msg)
472 (get-entry-link entry)
473 (get-msg-feed-title! msg)
474 (get-entry-title entry))))
475
476 (defmethod feedbot-announce ((bot feedbot))
477 "Announce new messages found by `bot'."
478 (let ((sent-msgs 0)
479 (nicks nil))
480 ;; Main queue processing routine.
481 (feedbot-process-msg-queue
482 bot #'(lambda (msg)
483 (when (not (get-msg-sent! msg))
484 ;; Wait a bit
485 (sleep *announce-delay*)
486 ;; Announce new entry to irc: if msg recipient is a
487 ;; channel, then send it and mark as sent. Else queue to
488 ;; list of nicks to be handled using the ISON reply.
489 (let ((rcpt (get-msg-to! msg)))
490 (when (channel-rcpt-p rcpt)
491 (announce-irc! bot msg)
492 (set-msg-sent! msg))
493 (when (nickname-rcpt-p rcpt)
494 (pushnew rcpt nicks :test #'string=))))
495 ;; If the case, keep a counter of sent-msgs
496 (when *max-sent-msgs*
497 (if (get-msg-sent! msg) (incf sent-msgs)))))
498 ;; Send ISON messages
499 (send-ison bot nicks)
500 ;; If the case, garbage collect old messages.
501 (when *max-sent-msgs*
502 (if (> sent-msgs *max-sent-msgs*)
503 (feedbot-delete-sent-msgs bot)))))
504
505 (defun announcer-thread (bot)
506 "A loop that announces new feeds."
507 (loop do
508 ;; Wait for a while
509 (sleep *announce-freq*)
510 ;; Check for new messages and announce them
511 (feedbot-announce bot)))
512
513 (defmethod feedbot-start-announcer-thread ((bot feedbot))
514 "Start `bot' announcer."
515 (with-slots (announcer-thread) bot
516 (assert (or (null announcer-thread)
517 (and (eql (type-of announcer-thread) 'thread)
518 (not (thread-alive-p announcer-thread)))))
519 (setf announcer-thread
520 (make-thread
521 #'announcer-thread
522 :name "feedbot-announcer-thread"
523 :arguments (list bot)))))
524
525 (defmethod feedbot-stop-announcer-thread ((bot feedbot))
526 "Stop feed announcer loop for `bot'."
527 (with-slots (announcer-thread) bot
528 (terminate-thread announcer-thread)
529 (setf announcer-thread nil)))
530
531 ;; VII. State management
532 ;; ---------------------
533 ;;
534 ;; Feedbot state is a list of the form:
535 ;;
536 ;; (feed-db msg-queue)
537 ;;
538 ;; where feed-db is a feed db and msg-queue is a message queue.
539 ;;
540 ;; Feedbot state is kept persistent using the following methods:
541 (defmethod feedbot-save-state ((bot feedbot) &optional (path "state.sexp"))
542 "Save bot state to disk location given by `path'."
543 (let ((feed-db (with-feed-db (feed-db) bot feed-db))
544 (msg-queue (with-msg-queue (msg-queue) bot msg-queue)))
545 (with-open-file (out path
546 :direction :output
547 :if-does-not-exist :create
548 :if-exists :supersede)
549 (write (list feed-db msg-queue) :stream out)
550 nil)))
551
552 (defmethod feedbot-flush-state ((bot feedbot) &optional (path "state.sexp"))
553 "Save bot state to disk location given by `path' and clear existing
554 state."
555 (feedbot-save-state bot path)
556 (with-feed-db (feed-db) bot
557 (setf feed-db nil))
558 (with-msg-queue (msg-queue) bot
559 (setf msg-queue nil)))
560
561 (defmethod feedbot-reload-state ((bot feedbot) &optional (path "state.sexp"))
562 "Reload bot state from disk location given by `path'."
563 (let ((state (with-open-file (in path :direction :input)
564 (read in))))
565 (with-feed-db (feed-db) bot
566 (setf feed-db (car state)))
567 (with-msg-queue (msg-queue) bot
568 (setf msg-queue (cadr state)))
569 nil))
570
571 (defmethod feedbot-load-state ((bot feedbot) &optional (path "state.sexp"))
572 "Load bot state from disk location given by `path'.
573
574 This method throws an error condition if the bot contains pre-existing
575 state, i.e. `feed-db' and `msg-queue' are non-NIL."
576 (with-slots (feed-db msg-queue) bot
577 (assert (not feed-db))
578 (assert (not msg-queue)))
579 (feedbot-reload-state bot path))
580
581 ;; VIII. Ircbot glue
582 ;; -----------------
583 ;;
584 ;; IRC glue:
585 ;;
586 ;; a. implements entry announcer [VI] functionality
587 ;; b. starts the checker and announcer threads on rpl_welcome
588 ;; c. sends messages to online nicks on rpl_ison
589 ;; d. implements ircbot-{connect,disconnect} routines
590
591 ;; -- a. Entry announcer
592 (defun announce-irc! (bot msg)
593 (announce-stdout! msg)
594 (let ((rcpt (get-msg-to! msg))
595 (entry (get-msg-entry! msg)))
596 (ircbot-send-message bot rcpt
597 (format nil "~a << ~a -- ~a~%"
598 (get-entry-link entry)
599 (get-msg-feed-title! msg)
600 (get-entry-title entry)))))
601
602 ;; -- b. rpl_welcome handler
603 (defun feedbot-rpl_welcome (bot message)
604 (declare (ignore message))
605 (feedbot-start-checker-thread bot)
606 (feedbot-start-announcer-thread bot))
607
608 ;; -- c. rpl_ison handler
609 (defun feedbot-rpl_ison (bot message)
610 ;; Only when our reply contains some nicks...
611 (when (cdr (arguments message))
612 (let ((nicks (parse-ison (cadr (arguments message)))))
613 ;; Process messages...
614 (feedbot-process-msg-queue
615 bot #'(lambda (msg)
616 ;; Only when msg not send and :to is online...
617 (when (and (not (get-msg-sent! msg))
618 (member (get-msg-to! msg) nicks
619 :test #'string=))
620 ;; Wait a bit
621 (sleep *announce-delay*)
622 ;; Announce and mark as sent.
623 (announce-irc! bot msg)
624 (set-msg-sent! msg)))))))
625
626 ;; -- d. Ircbot methods
627 (defmethod ircbot-connect :after ((bot feedbot))
628 (feedbot-load-state bot)
629 (let ((conn (ircbot-connection bot)))
630 (add-hook conn 'irc-rpl_welcome-message
631 #'(lambda (message)
632 (feedbot-rpl_welcome bot message)))
633 (add-hook conn 'irc-rpl_ison-message
634 #'(lambda (message)
635 (feedbot-rpl_ison bot message)))))
636
637 (defmethod ircbot-disconnect :after ((bot feedbot)
638 &optional (quit-msg "feedbot out"))
639 (declare (ignore quit-msg))
640 (with-slots (db-mutex queue-mutex checker-thread announcer-thread) bot
641 (ignore-errors
642 (release-mutex db-mutex :if-not-owner :force)
643 (release-mutex queue-mutex :if-not-owner :force)
644 (terminate-thread checker-thread)
645 (terminate-thread announcer-thread))
646 (setf checker-thread nil
647 announcer-thread nil)
648 (feedbot-flush-state bot)))
649
650 ;; IX. Trilemabot commands
651 ;; -----------------------
652 (trilemabot-define-cmd (:help bot message target arguments)
653 (declare (ignore arguments))
654 (ircbot-send-message bot (response-rcpt bot message target)
655 "http://thetarpit.org/posts/y05/081-feedbot-manual.html"))
656
657 (defmacro respond-invalid-arg (bot target)
658 `(ircbot-send-message ,bot ,target
659 "Please provide a valid feed URL"))
660
661 (defmacro respond-already-subscribed (bot rcpt url)
662 `(ircbot-send-message ,bot ,rcpt
663 (format nil "~a is already subscribed to ~a"
664 ,rcpt ,url)))
665
666 (defmacro respond-subscribed (bot rcpt url)
667 `(ircbot-send-message ,bot ,rcpt
668 (format nil "~a is now subscribed to ~a"
669 ,rcpt ,url)))
670
671 (defmacro respond-not-subscribed (bot rcpt url)
672 `(ircbot-send-message ,bot ,rcpt
673 (format nil "~a is not subscribed to ~a"
674 ,rcpt ,url)))
675
676 (defmacro respond-unsubscribed (bot rcpt url)
677 `(ircbot-send-message ,bot ,rcpt
678 (format nil "~a is now unsubscribed from ~a"
679 ,rcpt ,url)))
680
681 (trilemabot-define-cmd (:subscribe bot message target arguments)
682 ;; Execute everything inside a named block, to handle control-flow
683 ;; smoothly
684 (block cmd-body
685 (let ((rcpt (response-rcpt bot message target))
686 (url (parse-arguments arguments)))
687 ;; Invalid URL or malformed XML
688 (when (not (try-parse-feed url))
689 (respond-invalid-arg bot rcpt)
690 (return-from cmd-body))
691
692 (with-feed-db (feed-db) bot
693 (let ((feed (lookup-feed! url feed-db)))
694 ;; Nobody has subscribed to feed before?
695 (when (null feed)
696 (setq feed (make-feed url))
697 (push feed feed-db))
698
699 ;; Nick is already subscribed
700 (when (find-rcpt-in-feed! feed rcpt)
701 (respond-already-subscribed bot rcpt url)
702 (return-from cmd-body))
703
704 ;; Nick is not subscribed -- add new rcpt
705 (push-rcpt-to-feed! feed rcpt)
706 (respond-subscribed bot rcpt url))))))
707
708 (trilemabot-define-cmd (:unsubscribe bot message target arguments)
709 ;; Execute everything inside a named block, to handle control-flow
710 ;; smoothly
711 (block cmd-body
712 (let ((rcpt (response-rcpt bot message target))
713 (url (parse-arguments arguments)))
714 ;; Empty URL
715 (when (string= url "")
716 (respond-invalid-arg bot rcpt)
717 (return-from cmd-body))
718
719 (with-feed-db (feed-db) bot
720 (let ((feed (lookup-feed! url feed-db)))
721 ;; Feed not found
722 (when (not feed)
723 (respond-not-subscribed bot rcpt url)
724 (return-from cmd-body))
725
726 ;; Nick not a recipient in feed
727 (when (not (find-rcpt-in-feed! feed rcpt))
728 (respond-not-subscribed bot rcpt url)
729 (return-from cmd-body))
730
731 ;; Nick is subscribed -- remove from rcpt list
732 (delete-rcpt-from-feed! feed rcpt)
733 (respond-unsubscribed bot rcpt url))))))
734
735 (trilemabot-define-cmd (:list bot message target arguments)
736 (declare (ignore arguments))
737 ;; Execute everything inside a named block, to handle control-flow
738 ;; smoothly
739 (block cmd-body
740 (let ((rcpt (response-rcpt bot message target)))
741 ;; Never respond to list in channel
742 (when (channel-rcpt-p rcpt)
743 (return-from cmd-body))
744
745 ;; Get list of feed ids for rcpt and send them one by one in a
746 ;; separate reply each. Delay the response to avoid flooding.
747 (let ((ids-titles
748 (feedbot-select-feeds bot
749 :fields '(:id :title)
750 :where #'(lambda (feed)
751 (find-rcpt-in-feed!
752 feed rcpt)))))
753 (loop for val in ids-titles do
754 (destructuring-bind (feed-id feed-title) val
755 (sleep *announce-delay*)
756 (ircbot-send-message bot rcpt
757 (format nil "~a << ~a"
758 feed-id feed-title))))))))