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"
47 (defcustom lirc-networks
48 '(("libera" "irc.libera.chat" 6697)
49 ("freenode" "chat.freenode.net" 6697)
50 ("local" "localhost" 6697))
53 (defcustom lirc-prompt-string "> "
60 '((t :inherit font-lock-preprocessor-face))
61 "Face used for Lirc text.")
63 (defface lirc-your-nick
64 '((t :inherit font-lock-constant-face))
65 "Face used for highlighting your nick.")
68 '((t :inherit org-level-2))
69 "Face used for the prompt.")
72 '((t :inherit org-list-dt))
73 "Face used for the channel name in the prompt.")
76 '((t :inherit font-lock-preprocessor-face))
77 "Face used for faded Lirc text.")
80 '((t :inherit font-lock-function-name-face))
81 "Face used for bold Lirc text.")
84 '((t :inherit font-lock-regexp-grouping-construct))
85 "Face used for Lirc error text.")
90 (defvar lirc-version "Lirc v0.1")
92 (defvar lirc-notice-prompt
95 "-" 'face 'lirc-faded)
99 "-" 'face 'lirc-faded)))
101 (defvar lirc-error-prompt
102 (propertize "!!!" 'face 'lirc-error))
107 (defvar lirc-response "")
109 (defun lirc-filter (proc string)
110 (dolist (line (split-string (concat lirc-response string) "\n"))
111 (if (string-suffix-p "\r" line)
112 (lirc-eval-msg-string (string-trim line))
113 (setq lirc-response line))))
116 (defun lirc-start-process (network)
117 (let* ((row (assoc network lirc-networks))
120 (make-network-process :name "lirc"
123 :filter #'lirc-filter
125 :tls-parameters (cons 'gnutls-x509pki
126 (gnutls-boot-parameters
127 :type 'gnutls-x509pki
132 (defun lirc-connect (network)
133 (setq lirc-channel-list nil)
134 (setq lirc-current-channel nil)
135 (lirc-start-process network)
136 (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name))
137 (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick)))
139 (defun lirc-send-msg (msg)
140 (let ((proc (get-process "lirc")))
141 (if (and proc (eq (process-status proc) 'open))
142 (process-send-string proc (concat (lirc-msg->string msg) "\r\n"))
143 (lirc-display-error "No server connection established.")
144 (error "No server connection established"))))
149 (defun lirc-as-string (obj)
151 (with-output-to-string (princ obj))
154 (defun lirc-msg (tags src cmd &rest params)
155 (list (lirc-as-string tags)
157 (upcase (lirc-as-string cmd))
158 (mapcar #'lirc-as-string
159 (if (and params (listp (elt params 0)))
163 (defun lirc-msg-tags (msg) (elt msg 0))
164 (defun lirc-msg-src (msg) (elt msg 1))
165 (defun lirc-msg-cmd (msg) (elt msg 2))
166 (defun lirc-msg-params (msg) (elt msg 3))
167 (defun lirc-msg-trail (msg)
168 (let ((params (lirc-msg-params msg)))
170 (elt params (- (length params) 1)))))
172 (defvar lirc-msg-regex
174 (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
176 (opt (: ":" (: (group (* (not (any space "!" "@"))))
177 (* (not (any space)))))
179 (group (: (* (not whitespace))))
181 (opt (group (+ not-newline))))
182 "Regex used to parse IRC messages.
183 Note that this regex is incomplete. Noteably, we discard the non-nick
184 portion of the source component of the message, as LIRC doesn't use this.")
186 (defun lirc-string->msg (string)
187 (if (string-match lirc-msg-regex string)
188 (let* ((tags (match-string 1 string))
189 (src (match-string 2 string))
190 (cmd (upcase (match-string 3 string)))
191 (params-str (match-string 4 string))
194 (let* ((idx (cl-search ":" params-str))
195 (l (split-string (string-trim (substring params-str 0 idx))))
196 (r (if idx (list (substring params-str (+ 1 idx))) nil)))
199 (apply #'lirc-msg (append (list tags src cmd) params)))
200 (error "Failed to parse string " string)))
202 (defun lirc--filtered-join (&rest args)
203 (string-join (seq-filter (lambda (el) el) args) " "))
205 (defun lirc-msg->string (msg)
206 (let ((tags (lirc-msg-tags msg))
207 (src (lirc-msg-src msg))
208 (cmd (lirc-msg-cmd msg))
209 (params (lirc-msg-params msg)))
211 (if tags (concat "@" tags) nil)
212 (if src (concat ":" src) nil)
214 (if (> (length params) 1)
215 (string-join (seq-take params (- (length params) 1)) " ")
217 (if (> (length params) 0)
218 (concat ":" (elt params (- (length params) 1)))
222 ;;; Channels and users
225 (defvar lirc-current-channel nil)
227 (defun lirc-channel (name next prev users)
228 (list name prev next users))
230 (defun lirc-get-channel-name (channel)
232 (defun lirc-get-channel-next (channel)
234 (defun lirc-get-channel-prev (channel)
236 (defun lirc-get-channel-users (channel)
239 (defun lirc-set-channel-name (channel name)
240 (setf (elt channel 0) name))
241 (defun lirc-set-channel-next (channel next)
242 (setf (elt channel 1) next))
243 (defun lirc-set-channel-prev (channel prev)
244 (setf (elt channel 2) prev))
245 (defun lirc-set-channel-users (channel users)
246 (setf (elt channel 3) users))
248 (defun lirc-add-channel (new-channel)
249 (if lirc-current-channel
250 (let* ((prev lirc-current-channel)
251 (next (lirc-get-channel-next lirc-current-channel)))
252 (lirc-set-channel-next new-channel prev)
253 (lirc-set-channel-prev new-channel next))
254 (lirc-set-channel-next new-channel new-channel)
255 (lirc-set-channel-prev new-channel new-channel))
256 (setq lirc-current-channel new-channel))
258 (defun lirc-del-channel (channel)
259 (let ((prev (lirc-get-channel-prev channel))
260 (next (lirc-get-channel-next channel)))
264 (lirc-set-channel-next prev nil)
265 (lirc-set-channel-prev prev nil)
266 (setq lirc-current-channel prev))
267 (lirc-set-channel-next prev next)
268 (lirc-set-channel-prev next prev)
269 (if (eq channel lirc-current-channel)
270 (setq lirc-current-channel prev)))
271 (setq lirc-current-channel nil))))
273 (defun lirc-channel-do (proc)
274 (if lirc-current-channel
275 (let ((channel lirc-current-channel))
276 (funcall proc lirc-current-channel)
277 (while (not (eq (lirc-get-channel-next channel) lirc-current-channel))
278 (setq channel (lirc-get-channel-next channel))
279 (funcall proc channel)))))
281 (defun lirc-get-channel-with-name (channel-name)
282 (if lirc-current-channel
283 (let ((channel lirc-current-channel))
284 (while (and (not (equal (lirc-get-channel-name channel) channel-name))
285 (not (eq (lirc-get-channel-next channel) lirc-current-channel)))
286 (setq channel (lirc-get-channel-next channel)))
287 (if (equal (lirc-get-channel-name channel) channel-name)
292 (defun lirc-add-channel-with-name (channel-name)
293 (lirc-add-channel (lirc-channel channel-name nil nil nil)))
295 (defun lirc-add-channel-users (channel &rest users)
296 (lirc-set-channel-users channel (append users (lirc-get-channel-users channel))))
298 (defun lirc-del-channel-users (channel &rest users)
299 (lirc-set-channel-users channel (cl-set-difference (lirc-get-channel-users channel) users)))
301 (defun lirc-del-users (&rest users)
304 (lirc-set-channel-users
307 (lirc-get-channel-users channel)
311 (defun lirc-rename-user (old-nick new-nick)
314 (lirc-set-channel-users
315 (cons new-nick (delete old-nick (lirc-get-channel-users channel)))))))
317 (defun lirc-cycle-channels ()
319 (if lirc-current-channel
321 (setq lirc-current-channel (lirc-get-channel-next lirc-current-channel))
322 (lirc-render-prompt))
323 (lirc-display-error "No channels joined.")))
328 (defun lirc-display-string (&rest strings)
329 (with-current-buffer (get-buffer-create "*lirc*")
331 (goto-char lirc-prompt-marker)
332 (let ((inhibit-read-only t)
333 (old-pos (marker-position lirc-prompt-marker))
334 (adaptive-fill-regexp (rx (= 6 anychar))))
335 (insert-before-markers
336 (propertize (concat (format-time-string "%H:%M") " ")
339 (propertize (concat (apply #'concat strings) "\n")
341 (fill-region old-pos lirc-prompt-marker)))))
343 (defun lirc-render-prompt ()
344 (with-current-buffer "*lirc*"
346 (set-marker-insertion-type lirc-prompt-marker nil)
347 (set-marker-insertion-type lirc-input-marker t)
348 (let ((inhibit-read-only t))
349 (delete-region lirc-prompt-marker lirc-input-marker)
350 (goto-char lirc-prompt-marker)
352 (propertize (if lirc-current-channel
353 (lirc-get-channel-name lirc-current-channel)
357 (propertize lirc-prompt-string
361 (set-marker-insertion-type lirc-input-marker nil))))
363 (defvar lirc-prompt-marker nil
364 "Marker for prompt position in LIRC buffer.")
366 (defvar lirc-input-marker nil
367 "Marker for prompt position in LIRC buffer.")
369 (defun lirc-setup-buffer ()
370 (with-current-buffer (get-buffer-create "*lirc*")
371 (if (markerp lirc-prompt-marker)
372 (set-marker lirc-prompt-marker (point-max))
373 (setq lirc-prompt-marker (point-max-marker)))
374 (if (markerp lirc-input-marker)
375 (set-marker lirc-input-marker (point-max))
376 (setq lirc-input-marker (point-max-marker)))
378 (goto-char (point-max))
382 ;;; Output formatting
385 (defun lirc-display-action (channel-name nick action)
386 (lirc-display-string (concat channel-name
388 (propertize (concat nick " " action)
391 (defun lirc-display-private-message (target nick message)
396 (if (equal target lirc-nick)
400 (propertize (concat "<" nick "> " message) 'face 'lirc-text))))
403 (defun lirc-display-message (channel nick message)
406 (propertize (concat (lirc-get-channel-name channel) " ")
408 (propertize (concat "<" nick "> ")
410 (if (equal nick lirc-nick)
413 (propertize message 'face 'lirc-text))))
415 (defun lirc-display-notice (&rest notices)
416 (lirc-display-string lirc-notice-prompt " " (apply #'concat notices)))
418 (defun lirc-display-error (&rest messages)
419 (lirc-display-string lirc-error-prompt " "
420 (propertize (apply #'concat messages)
423 ;;; Message evaluation
426 (defun lirc-eval-msg-string (string)
427 ;; (lirc-display-string string)
428 (let* ((msg (lirc-string->msg string)))
429 (pcase (lirc-msg-cmd msg)
432 (lirc-msg nil nil "PONG" (lirc-msg-params msg)))
433 (lirc-display-notice "ping-pong"))
436 (let* ((params (lirc-msg-params msg))
437 (channel-name (elt params 2))
438 (names (split-string (elt params 3))))
439 (apply #'lirc-add-channel-users
440 (cons (lirc-get-channel-with-name channel-name) names))))
444 (lirc-as-string (length (lirc-get-channel-users lirc-current-channel)))
445 " users in " (lirc-get-channel-name lirc-current-channel)))
447 ((rx (= 3 (any digit)))
448 (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " ")))
451 (guard (equal lirc-nick (lirc-msg-src msg))))
452 (let ((channel-name (car (lirc-msg-params msg))))
453 (lirc-add-channel-with-name channel-name)
454 (lirc-display-notice "Joining channel " channel-name)
455 (lirc-render-prompt)))
458 (let ((channel-name (car (lirc-msg-params msg)))
459 (nick (lirc-msg-src msg)))
460 (lirc-add-channel-users (lirc-get-channel-with-name channel-name) nick)
461 (lirc-display-notice nick " joined channel " channel-name)))
464 (guard (equal lirc-nick (lirc-msg-src msg))))
465 (let ((channel-name (car (lirc-msg-params msg))))
466 (lirc-display-notice "Left channel " channel-name)
467 (lirc-del-channel (lirc-get-channel-with-name channel-name))
468 (lirc-render-prompt)))
471 (let ((channel-name (car (lirc-msg-params msg)))
472 (nick (lirc-msg-src msg)))
473 (lirc-del-channel-users (lirc-get-channel channel-name) nick)
474 (lirc-display-notice nick " left channel " channel-name)))
477 (let ((nick (lirc-msg-src msg))
478 (reason (mapconcat 'identity (lirc-msg-params msg) " ")))
479 (lirc-del-users nick)
480 (lirc-display-notice nick " quit: " reason)))
483 (guard (equal lirc-nick (lirc-msg-src msg))))
484 (setq lirc-nick (car (lirc-msg-params msg)))
485 (lirc-display-notice "Set nick to " lirc-nick))
488 (let ((old-nick (lirc-msg-src msg))
489 (new-nick (car (lirc-msg-params msg))))
490 (lirc-display-notice nick " is now known as " new-nick)
491 (lirc-rename-user nick new-nick)))
494 (let ((nick (lirc-msg-src msg))
495 (channel (car (lirc-msg-params msg)))
496 (text (cadr (lirc-msg-params msg))))
498 ((rx (: "\01VERSION "
499 (let version (* (not "\01")))
501 (lirc-display-notice "CTCP version reply from " nick ": " version))
503 (lirc-display-notice text)))))
506 (let ((nick (lirc-msg-src msg))
507 (channel (lirc-get-channel-with-name (car (lirc-msg-params msg))))
508 (text (cadr (lirc-msg-params msg))))
511 (let action (* (not "\01")))
513 (lirc-display-action channel nick action))
516 (let ((version-string (concat lirc-version " - running on GNU Emacs " emacs-version)))
517 (lirc-send-msg (lirc-msg nil nil "NOTICE"
518 (list nick (concat "\01VERSION "
521 (lirc-display-notice "CTCP version request received from " nick))
523 ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
524 (lirc-send-msg (lirc-msg nil nil "NOTICE" (list nick ping)))
525 (lirc-display-notice "CTCP ping received from " nick))
528 (lirc-display-notice "CTCP userinfo request from " nick " (no response sent)"))
532 (lirc-display-message channel nick text)
533 (lirc-display-private-message (car (lirc-msg-params msg)) nick text))))))
535 (lirc-display-string (lirc-msg->string msg))))))
541 (defun lirc-enter-string (string)
542 (if (string-prefix-p "/" string)
543 (pcase (substring string 1)
544 ((rx (: "CONNECT " (let network (* not-newline))))
545 (lirc-display-notice "Connecting to " network "...")
546 (lirc-connect network))
548 ((rx (: "TOPIC " (let new-topic (* not-newline))))
549 (lirc-send-msg (lirc-msg nil nil "TOPIC" lirc-current-channel new-topic)))
551 ((rx (: "ME " (let action (* not-newline))))
552 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
553 (list lirc-current-channel
554 (concat "\01ACTION " action "\01"))))
555 (lirc-display-action lirc-nick action))
557 ((rx (: "VERSION" " " (let nick (* (not whitespace)))))
558 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
559 (list nick "\01VERSION\01")))
560 (lirc-display-notice "CTCP version request sent to " nick))
562 ((rx "PART" (opt (: " " (let channel (* not-newline)))))
563 (if (or lirc-current-channel channel)
564 (lirc-send-msg (lirc-msg nil nil "PART" (if channel
566 lirc-current-channel)))
567 (lirc-display-error "No current channel to leave.")))
570 (let target (* (not whitespace)))
572 (let text (* not-newline)))
573 (lirc-send-msg (lirc-msg nil nil "PRIVMSG" target text))
574 (lirc-display-private-message target lirc-nick text))
576 ((rx (: (let cmd-str (+ (not whitespace)))
577 (opt (: " " (let params-str (* not-newline))))))
578 (lirc-send-msg (lirc-msg nil nil (upcase cmd-str)
580 (split-string params-str)
583 (unless (string-empty-p string)
584 (if lirc-current-channel
586 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
587 (lirc-get-channel-name lirc-current-channel)
589 (lirc-display-message lirc-current-channel lirc-nick string))
590 (lirc-display-error "No current channel.")))))
593 "Enter current contents of line after prompt."
595 (with-current-buffer "*lirc*"
597 (buffer-substring lirc-input-marker (point-max)))
598 (let ((inhibit-read-only t))
599 (delete-region lirc-input-marker (point-max)))))
606 (defvar lirc-mode-map
607 (let ((map (make-sparse-keymap)))
608 (define-key map (kbd "RET") 'lirc-enter)
609 (define-key map (kbd "<C-tab>") 'lirc-cycle-channels)
612 (define-derived-mode lirc-mode text-mode "lirc"
613 "Major mode for LIRC.")
615 (when (fboundp 'evil-set-initial-state)
616 (evil-set-initial-state 'lirc-mode 'insert))
618 ;;; Main start procedure
622 "Switch to *lirc* buffer."
624 (if (get-buffer "*lirc*")
625 (switch-to-buffer "*lirc*")
626 (switch-to-buffer "*lirc*"))
633 ;;; lirc.el ends here