/[lisppaste]/lisppaste2/irc-notification.lisp
ViewVC logotype

Contents of /lisppaste2/irc-notification.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Sat May 29 14:19:47 2010 UTC (3 years, 10 months ago) by lisppaste
Branch: MAIN
CVS Tags: HEAD
Changes since 1.13: +10 -2 lines
Latest anti-spam changes.
1 ;;;; $Id: irc-notification.lisp,v 1.14 2010/05/29 14:19:47 lisppaste Exp $
2 ;;;; $Source: /tiger/var/lib/cvsroots/lisppaste/lisppaste2/irc-notification.lisp,v $
3
4 ;;;; See the LICENSE file for licensing information.
5
6 (in-package :lisppaste)
7
8 (defvar *connections* nil)
9 (defvar *nicknames* nil)
10 (defparameter *channel-limit* 19)
11 (defparameter *status-channel* "#lisppaste-status")
12 ;; FIXME: should be in variable.lisp
13
14 (defun find-free-nick ()
15 (cdr (find-if (lambda (pair)
16 (< (length (car pair)) *channel-limit*))
17 (reverse *nicknames*))))
18
19 (defun channel-nick (channel)
20 (cdr (assoc channel *nicknames*
21 :test #'(lambda (e s)
22 (member e s :test #'string-equal)))))
23
24 (defun nick-connection (nick)
25 (cdr (assoc nick *connections* :test #'string-equal)))
26
27 (defun find-connection (channel)
28 (nick-connection (channel-nick channel)))
29
30 (defun irc-say-help (channel)
31 (when (and (find-connection channel)
32 (find channel *channels* :test #'string-equal))
33 (irc:privmsg (find-connection channel)
34 channel
35 (format nil "To use the lisppaste bot, visit ~A/~A and enter your paste." (araneida:urlstring *new-paste-url*) (araneida:urlstring-escape (subseq channel 1))))
36 t))
37
38 (defun excluding-trailing-digits (nick)
39 (coerce
40 (loop for i from (1- (length nick)) downto 0
41 if (not (digit-char-p (elt nick i)))
42 return (subseq nick 0 (1+ i)))
43 'string))
44
45 (defun help-request-p (nick help text)
46 (and (> (length text)
47 (length nick))
48 (search nick text :start2 0 :end2 (length nick) :test #'char-equal)
49 (let ((url-position (search help text :start2 (length nick)
50 :test #'char-equal)))
51 (and
52 url-position
53 (notany #'alpha-char-p (subseq text (length nick) (1- url-position)))
54 (notany #'alpha-char-p (subseq text (+ url-position (length help))))))))
55
56 (defun make-irc-msg-hook (connection nick)
57 (lambda (message)
58 (let ((text (irc:trailing-argument message)))
59 (cond ((string-equal (first (irc:arguments message)) nick)
60 (irc:privmsg connection
61 (irc:source message)
62 (format nil "To use the lisppaste bot, visit ~A and enter your paste. Be sure to select the right channel!" (araneida:urlstring *new-paste-url*)))
63 ;; KLUDGE: keep from flooding off
64 (sleep 0.05))
65 ((some #'(lambda (e)
66 (help-request-p (excluding-trailing-digits nick) e text))
67 '("url" "help" "hello"))
68 (irc-say-help (first (irc:arguments message))))))))
69
70 (defun add-irc-hook (connection nick)
71 (irc:remove-hooks connection 'irc:irc-privmsg-message)
72 (irc:add-hook connection 'irc:irc-privmsg-message (make-irc-msg-hook connection nick)))
73
74 (defun start-irc-notification (&key (channels (list *default-channel*))
75 (nickname *default-nickname*)
76 (server *default-irc-server*)
77 (port *default-irc-server-port*))
78 (let ((connection (irc:connect :nickname nickname
79 :realname (araneida:urlstring *new-paste-url*)
80 :server server
81 :port port)))
82 (push (cons nickname connection) *connections*)
83 (setf channels
84 (mapcar (lambda (channel)
85 (cond ((consp channel)
86 (destructuring-bind (channel coloring-type) channel
87 (setf (gethash channel *coloring-type-defaults*)
88 coloring-type)
89 channel))
90 (t channel)))
91 channels))
92 (setf *channels* (append *channels* channels))
93 (push (cons (copy-list channels) nickname) *nicknames*)
94 (mapcar #'(lambda (channel) (irc:join connection channel)) channels)
95 (when *status-channel*
96 (irc:join connection *status-channel*))
97 (add-irc-hook connection nickname)
98 (irc:start-background-message-handler connection)
99 (sleep 5)))
100
101 (defun stop-irc-notification (nickname)
102 (ignore-errors (irc:quit (nick-connection nickname)))
103 (loop for i in (car (rassoc nickname *nicknames* :test #'string-equal))
104 do (setf *channels* (remove i *channels* :test #'string-equal)))
105 (setf *nicknames* (remove nickname *nicknames* :key #'cdr :test #'string-equal))
106 (setf *connections* (remove nickname *connections* :key #'car :test #'string-equal)))
107
108 (defun join-new-irc-channel (nickname channel &optional coloring-type)
109 (push channel (car (rassoc nickname *nicknames* :test #'string-equal)))
110 (irc:join (find-connection channel) channel)
111 (when coloring-type
112 (setf (gethash channel *coloring-type-defaults*)
113 coloring-type))
114 (setf *channels* (nconc *channels* (list channel))))
115
116 (defun leave-irc-channel (nickname channel)
117 (setf *channels* (remove channel *channels* :test #'string-equal))
118 (irc:part (find-connection channel) channel)
119 (setf (car (rassoc nickname *nicknames* :test #'string-equal))
120 (remove channel (car (rassoc nickname *nicknames* :test #'string-equal))
121 :test #'string-equal)))
122
123 (defun make-quit-msg (nickname)
124 (format nil "Want ~A in your channel? Email ~{~A~^ AT ~}." nickname (split-sequence:split-sequence #\@ *owner-email*)))
125
126 (defun quit-all-connections ()
127 (mapc #'(lambda (e)
128 (ignore-errors
129 (irc:quit (cdr e)
130 (make-quit-msg (car e)))))
131 *connections*))
132
133 (defun hup-all-connections ()
134 (mapc #'hup-irc-connection (mapcar #'car *connections*)))
135
136 (defun hup-irc-connection (nickname &optional (server *default-irc-server*))
137 (ignore-errors (irc:quit (nick-connection nickname) (make-quit-msg nickname)))
138 (sleep 1)
139 (setf
140 (cdr (assoc nickname *connections* :test #'string-equal))
141 (irc:connect :nickname nickname
142 :realname (araneida:urlstring *new-paste-url*)
143 :server server
144 :port *default-irc-server-port*))
145 (mapcar #'(lambda (channel) (irc:join (nick-connection nickname) channel))
146 (car (rassoc nickname *nicknames* :test #'string-equal)))
147 (when *status-channel*
148 (irc:join (nick-connection nickname) *status-channel*))
149 (add-irc-hook (nick-connection nickname) nickname)
150 (irc:start-background-message-handler (nick-connection nickname)))
151
152 (defun %shut-up (connection)
153 (setf (irc:client-stream connection)
154 (make-broadcast-stream)))
155
156 (defun shut-up ()
157 (mapc #'%shut-up (mapcar #'cdr *connections*)))
158
159 (defun %un-shut-up (connection)
160 (setf (irc:client-stream connection) *trace-output*))
161
162 (defun un-shut-up ()
163 (mapc #'%un-shut-up (mapcar #'cdr *connections*)))
164
165 (defun irc-notify (channel text)
166 (let ((connection (find-connection channel)))
167 (when connection
168 (irc:privmsg connection channel
169 (remove-if (lambda (char)
170 (or (eql char #\newline)
171 (eql char #\return)))
172 text)))))
173
174 (defun notify-all-channels (text)
175 (loop for channel in *channels*
176 do (irc-notify channel text)
177 do (sleep 5)))

  ViewVC Help
Powered by ViewVC 1.1.5