1 ;;; lirc.el --- Lightweight irc client -*- lexical-binding:t -*-
3 ;; Copyright (C) 2021 Tim Vaughan
5 ;; Author: Tim Vaughan <timv@ughan.xyz>
6 ;; Created: 14 June 2021
9 ;; Homepage: http://thelambdalab.xyz/erc
10 ;; Package-Requires: ((emacs "26"))
12 ;; This file is not part of GNU Emacs.
14 ;; This program is free software: you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation, either version 3 of the License, or
17 ;; (at your option) any later version.
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with this file. If not, see <http://www.gnu.org/licenses/>.
37 "Lightweight IRC client."
40 (defcustom lirc-nick "plugd"
42 (defcustom lirc-full-name "plugd"
44 (defcustom lirc-user-name "plugd"
46 (defcustom lirc-host "irc.libera.chat"
48 (defcustom lirc-port 6697
51 (defcustom lirc-prompt-string "> "
58 '((t :inherit font-lock-preprocessor-face))
59 "Face used for Lirc text.")
61 (defface lirc-your-nick
62 '((t :inherit font-lock-constant-face))
63 "Face used for highlighting your nick.")
66 '((t :inherit org-level-2))
67 "Face used for the prompt.")
70 '((t :inherit org-list-dt))
71 "Face used for the channel name in the prompt.")
74 '((t :inherit font-lock-preprocessor-face))
75 "Face used for faded Lirc text.")
78 '((t :inherit font-lock-function-name-face))
79 "Face used for bold Lirc text.")
82 '((t :inherit font-lock-regexp-grouping-construct))
83 "Face used for Lirc error text.")
88 (defvar lirc-version "Lirc v0.1")
90 (defvar lirc-notice-prompt
93 "-" 'face 'lirc-faded)
97 "-" 'face 'lirc-faded)))
99 (defvar lirc-error-prompt
100 (propertize "!!!" 'face 'lirc-error))
106 (defvar lirc-response "")
108 (defun lirc-filter (proc string)
109 (dolist (line (split-string (concat lirc-response string) "\n"))
110 (if (string-suffix-p "\r" line)
111 (lirc-eval-msg-string (string-trim line))
112 (setq lirc-response line))))
114 (defun lirc-get-process (&optional connect)
115 (let ((proc (get-process "lirc")))
116 (if (and proc (eq (process-status proc) 'open))
119 (make-network-process :name "lirc"
122 :filter #'lirc-filter
124 :tls-parameters (cons 'gnutls-x509pki
125 (gnutls-boot-parameters
126 :type 'gnutls-x509pki
127 :hostname lirc-host))
129 (lirc-display-error "No server connection established.")
130 (error "No server connection established")))))
135 (defun lirc-as-string (obj)
137 (with-output-to-string (princ obj))
140 (defun lirc-msg (tags src cmd &rest params)
141 (list (lirc-as-string tags)
143 (upcase (lirc-as-string cmd))
144 (mapcar #'lirc-as-string
145 (if (and params (listp (elt params 0)))
149 (defun lirc-msg-tags (msg) (elt msg 0))
150 (defun lirc-msg-src (msg) (elt msg 1))
151 (defun lirc-msg-cmd (msg) (elt msg 2))
152 (defun lirc-msg-params (msg) (elt msg 3))
153 (defun lirc-msg-trail (msg)
154 (let ((params (lirc-msg-params msg)))
156 (elt params (- (length params) 1)))))
158 (defvar lirc-msg-regex
160 (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
162 (opt (: ":" (: (group (* (not (any space "!" "@"))))
163 (* (not (any space)))))
165 (group (: (* (not whitespace))))
167 (opt (group (+ not-newline))))
168 "Regex used to parse IRC messages.
169 Note that this regex is incomplete. Noteably, we discard the non-nick
170 portion of the source component of the message, as LIRC doesn't use this.")
172 (defun lirc-string->msg (string)
173 (if (string-match lirc-msg-regex string)
174 (let* ((tags (match-string 1 string))
175 (src (match-string 2 string))
176 (cmd (upcase (match-string 3 string)))
177 (params-str (match-string 4 string))
180 (let* ((idx (cl-search ":" params-str))
181 (l (split-string (string-trim (substring params-str 0 idx))))
182 (r (if idx (list (substring params-str (+ 1 idx))) nil)))
185 (apply #'lirc-msg (append (list tags src cmd) params)))
186 (error "Failed to parse string " string)))
188 (defun lirc--filtered-join (&rest args)
189 (string-join (seq-filter (lambda (el) el) args) " "))
191 (defun lirc-msg->string (msg)
192 (let ((tags (lirc-msg-tags msg))
193 (src (lirc-msg-src msg))
194 (cmd (lirc-msg-cmd msg))
195 (params (lirc-msg-params msg)))
197 (if tags (concat "@" tags) nil)
198 (if src (concat ":" src) nil)
200 (if (> (length params) 1)
201 (string-join (seq-take params (- (length params) 1)) " ")
203 (if (> (length params) 0)
204 (concat ":" (elt params (- (length params) 1)))
211 (defvar lirc-current-channel nil)
212 (defvar lirc-channel-list nil)
214 (defun lirc-add-channel (channel-name)
215 (add-to-list 'lirc-channel-list
216 (list channel-name)))
218 (defun lirc-del-channel (channel-name)
219 (setq lirc-channel-list
220 (assoc-delete-all channel-name lirc-channel-list)))
222 (defun lirc-get-channel-users (channel-name)
223 (cdr (assoc channel-name lirc-channel-list)))
225 (defun lirc-set-channel-users (channel-name users)
226 (setcdr (assoc channel-name lirc-channel-list) users))
228 (defun lirc-add-channel-users (channel-name &rest users)
229 (let ((current-users (lirc-get-channel-users channel-name)))
230 (lirc-set-channel-users channel-name (append users current-users))))
232 (defun lirc-del-channel-users (channel-name &rest users)
233 (let ((current-users (lirc-get-channel-users channel-name)))
234 (lirc-set-channel-users channel-name
235 (cl-set-difference current-users users :test #'equal))))
237 (defun lirc-del-users (&rest users)
238 (dolist (channel lirc-channel-list)
239 (apply #'lirc-del-channel-users (cons (car channel) users))))
241 (defun lirc-rename-user (old-nick new-nick)
242 (dolist (channel lirc-channel-list)
243 (let ((channel-name (car channel))
244 (channel-users (cdr channel)))
245 (when (memq old-nick channel-users)
246 (lirc-del-channel-users old-nick)
247 (lirc-add-channel-users new-nick)))))
253 (defun lirc-display-string (&rest strings)
254 (with-current-buffer (get-buffer-create "*lirc*")
256 (goto-char lirc-prompt-marker)
257 (let ((inhibit-read-only t))
258 (insert-before-markers
259 (propertize (concat (format-time-string "%H:%M") " ")
262 (propertize (concat (apply #'concat strings) "\n")
265 (defun lirc-connect ()
267 (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name))
268 (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick)))
270 (defun lirc-send-msg (msg)
271 (let ((proc (lirc-get-process)))
272 (process-send-string proc (concat (lirc-msg->string msg) "\r\n"))))
274 (defun lirc-render-prompt ()
275 (with-current-buffer "*lirc*"
277 (set-marker-insertion-type lirc-prompt-marker nil)
278 (set-marker-insertion-type lirc-input-marker t)
279 (let ((inhibit-read-only t))
280 (delete-region lirc-prompt-marker lirc-input-marker)
281 (goto-char lirc-prompt-marker)
283 (propertize (if lirc-current-channel
288 (propertize lirc-prompt-string
292 (set-marker-insertion-type lirc-input-marker nil))))
294 (defvar lirc-prompt-marker nil
295 "Marker for prompt position in LIRC buffer.")
297 (defvar lirc-input-marker nil
298 "Marker for prompt position in LIRC buffer.")
300 (defun lirc-setup-buffer ()
301 (with-current-buffer (get-buffer-create "*lirc*")
302 (if (markerp lirc-prompt-marker)
303 (set-marker lirc-prompt-marker (point-max))
304 (setq lirc-prompt-marker (point-max-marker)))
305 (if (markerp lirc-input-marker)
306 (set-marker lirc-input-marker (point-max))
307 (setq lirc-input-marker (point-max-marker)))
309 (goto-char (point-max))
313 ;;; Output formatting
316 (defun lirc-display-action (channel nick action)
317 (lirc-display-string (concat " * "
318 (propertize (concat nick " " action)
321 (defun lirc-display-message (channel nick message)
324 (propertize (concat channel " ")
326 (propertize (concat "<" nick "> ")
328 (if (equal nick lirc-nick)
331 (propertize message 'face 'lirc-text))))
333 (defun lirc-display-notice (&rest notices)
334 (lirc-display-string lirc-notice-prompt " " (apply #'concat notices)))
336 (defun lirc-display-error (&rest messages)
337 (lirc-display-string lirc-error-prompt " "
338 (propertize (apply #'concat messages)
341 ;;; Message evaluation
344 (defun lirc-eval-msg-string (string)
345 ;; (lirc-display-string string)
346 (let* ((msg (lirc-string->msg string)))
347 (pcase (lirc-msg-cmd msg)
350 (lirc-msg nil nil "PONG" (lirc-msg-params msg))))
353 (let* ((params (lirc-msg-params msg))
354 (channel (elt params 2))
355 (names (split-string (elt params 3))))
356 (apply #'lirc-add-channel-users (cons channel names))))
360 (lirc-as-string (length (lirc-get-channel-users lirc-current-channel)))
361 " users in " lirc-current-channel))
363 ((rx (= 3 (any digit)))
364 (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " ")))
367 (guard (equal lirc-nick (lirc-msg-src msg))))
368 (let ((channel (car (lirc-msg-params msg))))
369 (setq lirc-current-channel channel)
370 (lirc-add-channel channel)
371 (lirc-display-notice "Joining channel " channel)
372 (lirc-render-prompt)))
375 (let ((channel (car (lirc-msg-params msg)))
376 (nick (lirc-msg-src msg)))
377 (lirc-add-channel-users channel nick)
378 (lirc-display-notice nick " joined channel " channel)))
381 (guard (equal lirc-nick (lirc-msg-src msg))))
382 (lirc-display-notice "Left channel " lirc-current-channel)
383 (setq lirc-current-channel nil)
384 (lirc-del-channel (car (lirc-msg-params msg)))
385 (lirc-render-prompt))
388 (let ((channel (car (lirc-msg-params msg)))
389 (nick (lirc-msg-src msg)))
390 (lirc-del-channel-users channel nick)
391 (lirc-display-notice nick " left channel " channel)))
394 (let ((nick (lirc-msg-src msg))
395 (reason (mapconcat 'identity (lirc-msg-params msg) " ")))
396 (lirc-del-users nick)
397 (lirc-display-notice nick " quit: " reason)))
400 (guard (equal lirc-nick (lirc-msg-src msg))))
401 (setq lirc-nick (car (lirc-msg-params msg)))
402 (lirc-display-notice "Set nick to " lirc-nick))
405 (let ((old-nick (lirc-msg-src msg))
406 (new-nick (car (lirc-msg-params msg))))
407 (lirc-display-notice nick " is now known as " new-nick)
408 (lirc-rename-user nick new-nick)))
411 (let ((nick (lirc-msg-src msg))
412 (channel (car (lirc-msg-params msg)))
413 (text (cadr (lirc-msg-params msg))))
415 ((rx (: "\01VERSION "
416 (let version (* (not "\01")))
418 (lirc-display-notice "CTCP version reply from " nick ": " version))
420 (lirc-display-notice text)))))
423 (let ((nick (lirc-msg-src msg))
424 (channel (car (lirc-msg-params msg)))
425 (text (cadr (lirc-msg-params msg))))
428 (let action (* (not "\01")))
430 (lirc-display-action nick action))
433 (let ((version-string (concat lirc-version " - running on GNU Emacs " emacs-version)))
434 (lirc-send-msg (lirc-msg nil nil "NOTICE"
435 (list nick (concat "\01VERSION "
438 (lirc-display-notice "CTCP version request received from " nick))
440 ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
441 (lirc-send-msg (lirc-msg nil nil "NOTICE" (list nick ping)))
442 (lirc-display-notice "CTCP ping received from " nick))
445 (lirc-display-notice "CTCP userinfo request from " nick " (no response sent)"))
448 (lirc-display-message channel nick text)))))
450 (lirc-display-string (lirc-msg->string msg))))))
456 (defun lirc-enter-string (string)
457 (if (string-prefix-p "/" string)
458 (pcase (substring string 1)
459 ((rx (: "TOPIC" " " (let new-topic (* not-newline))))
460 (lirc-send-msg (lirc-msg nil nil "TOPIC" lirc-current-channel new-topic)))
462 ((rx (: "me" " " (let action (* not-newline))))
463 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
464 (list lirc-current-channel
465 (concat "\01ACTION " action "\01"))))
466 (lirc-display-action lirc-nick action))
468 ((rx (: "VERSION" " " (let nick (* (not whitespace)))))
469 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
470 (list nick "\01VERSION\01")))
471 (lirc-display-notice "CTCP version request sent to " nick))
474 (lirc-send-msg (lirc-msg nil nil "PART" lirc-current-channel)))
477 (let target (* (not whitespace)))
479 (let text (* not-newline)))
480 (lirc-send-msg (lirc-msg nil nil "PRIVMSG" target text))
481 (lirc-display-message target lirc-nick text))
483 ((rx (: (let cmd-str (+ (not whitespace)))
484 (opt (: " " (let params-str (* not-newline))))))
485 (lirc-send-msg (lirc-msg nil nil (upcase cmd-str)
487 (split-string params-str)
490 (unless (string-empty-p string)
491 (lirc-send-msg (lirc-msg nil nil "PRIVMSG" lirc-current-channel string))
492 (lirc-display-message lirc-current-channel lirc-nick string))))
495 "Enter current contents of line after prompt."
497 (with-current-buffer "*lirc*"
499 (buffer-substring lirc-input-marker (point-max)))
500 (let ((inhibit-read-only t))
501 (delete-region lirc-input-marker (point-max)))))
508 (defvar lirc-mode-map
509 (let ((map (make-sparse-keymap)))
510 (define-key map (kbd "RET") 'lirc-enter)
513 (define-derived-mode lirc-mode text-mode "lirc"
514 "Major mode for LIRC.")
516 (when (fboundp 'evil-set-initial-state)
517 (evil-set-initial-state 'lirc-mode 'insert))
519 ;;; Main start procedure
523 "Switch to *lirc* buffer."
525 (if (get-buffer "*lirc*")
526 (switch-to-buffer "*lirc*")
527 (switch-to-buffer "*lirc*"))
535 ;;; lirc.el ends here