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/>.
38 "Lightweight IRC client."
41 (defcustom lirc-nick "plugd"
43 (defcustom lirc-full-name "plugd"
45 (defcustom lirc-user-name "plugd"
48 (defcustom lirc-networks
49 '(("libera" "irc.libera.chat" 6697)
50 ("freenode" "chat.freenode.net" 6697)
51 ("local" "localhost" 6697))
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-prefix
93 "-" 'face 'lirc-faded)
97 "-" 'face 'lirc-faded)))
99 (defvar lirc-error-prefix
100 (propertize "!!!" 'face 'lirc-error))
103 (defvar lirc-prompt-string
104 (propertize "> " 'face 'lirc-prompt))
110 (defvar lirc-response "")
112 (defun lirc-filter (proc string)
113 (dolist (line (split-string (concat lirc-response string) "\n"))
114 (if (string-suffix-p "\r" line)
115 (lirc-eval-msg-string (string-trim line))
116 (setq lirc-response line))))
119 (defun lirc-start-process (network)
120 (let* ((row (assoc network lirc-networks))
123 (make-network-process :name "lirc"
126 :filter #'lirc-filter
128 :tls-parameters (cons 'gnutls-x509pki
129 (gnutls-boot-parameters
130 :type 'gnutls-x509pki
135 (defun lirc-connect (network)
136 (if (get-process "lirc")
137 (lirc-display-error "Already connected. Disconnect first.")
138 (setq lirc-current-context nil)
139 (clrhash lirc-contexts)
140 (lirc-start-process network)
141 (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name))
142 (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick))))
144 (defun lirc-send-msg (msg)
145 (let ((proc (get-process "lirc")))
146 (if (and proc (eq (process-status proc) 'open))
147 (process-send-string proc (concat (lirc-msg->string msg) "\r\n"))
148 (lirc-display-error "No server connection established.")
149 (error "No server connection established"))))
155 (defun lirc--as-string (obj)
157 (with-output-to-string (princ obj))
160 (defun lirc-msg (tags src cmd &rest params)
161 (list (lirc--as-string tags)
162 (lirc--as-string src)
163 (upcase (lirc--as-string cmd))
164 (mapcar #'lirc--as-string
165 (if (and params (listp (elt params 0)))
169 (defun lirc-msg-tags (msg) (elt msg 0))
170 (defun lirc-msg-src (msg) (elt msg 1))
171 (defun lirc-msg-cmd (msg) (elt msg 2))
172 (defun lirc-msg-params (msg) (elt msg 3))
173 (defun lirc-msg-trail (msg)
174 (let ((params (lirc-msg-params msg)))
176 (elt params (- (length params) 1)))))
178 (defvar lirc-msg-regex
180 (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
182 (opt (: ":" (: (group (* (not (any space "!" "@"))))
183 (* (not (any space)))))
185 (group (: (* (not whitespace))))
187 (opt (group (+ not-newline))))
188 "Regex used to parse IRC messages.
189 Note that this regex is incomplete. Noteably, we discard the non-nick
190 portion of the source component of the message, as LIRC doesn't use this.")
192 (defun lirc-string->msg (string)
193 (if (string-match lirc-msg-regex string)
194 (let* ((tags (match-string 1 string))
195 (src (match-string 2 string))
196 (cmd (upcase (match-string 3 string)))
197 (params-str (match-string 4 string))
200 (let* ((idx (cl-search ":" params-str))
201 (l (split-string (string-trim (substring params-str 0 idx))))
202 (r (if idx (list (substring params-str (+ 1 idx))) nil)))
205 (apply #'lirc-msg (append (list tags src cmd) params)))
206 (error "Failed to parse string " string)))
208 (defun lirc--filtered-join (&rest args)
209 (string-join (seq-filter (lambda (el) el) args) " "))
211 (defun lirc-msg->string (msg)
212 (let ((tags (lirc-msg-tags msg))
213 (src (lirc-msg-src msg))
214 (cmd (lirc-msg-cmd msg))
215 (params (lirc-msg-params msg)))
217 (if tags (concat "@" tags) nil)
218 (if src (concat ":" src) nil)
220 (if (> (length params) 1)
221 (string-join (seq-take params (- (length params) 1)) " ")
223 (if (> (length params) 0)
224 (concat ":" (elt params (- (length params) 1)))
228 ;;; Contexts and users
231 (defvar lirc-context-table
232 '((channel lirc-display-channel-message)
233 (nick lirc-display-private-message)
234 (host lirc-diaplay-server-message)))
236 (defvar lirc-current-context nil)
237 (defvar lirc-contexts (make-hash-table :test #'equal))
239 (defun lirc-add-context (name)
240 (puthash name nil lirc-contexts))
242 (defun lirc-del-context (name)
243 (remhash name lirc-contexts))
245 (defun lirc-get-context-users (name)
246 (gethash name lirc-contexts))
248 (defun lirc-add-context-users (context users)
251 (gethash context lirc-contexts))
254 (defun lirc-del-context-user (context user)
256 (remove user (gethash context lirc-contexts))
259 (defun lirc-del-user (user)
260 (dolist (context (lirc-get-context-list))
261 (lirc-del-context-user context user)))
263 (defun lirc-get-context-type (name)
265 ((string-prefix-p "#" name) 'channel)
266 ((string-match-p (rx (or "." "localhost")) name) 'host)
269 (defun lirc-get-context-list ()
271 (maphash (lambda (key val)
272 (cl-pushnew key res))
276 (defun lirc-get-next-context ()
277 (if lirc-current-context
278 (let* ((context-list (lirc-get-context-list))
279 (context-list* (member lirc-current-context context-list)))
280 (if (> (length context-list*) 1)
286 (defun lirc-cycle-contexts ()
288 (if lirc-current-channel
290 (setq lirc-current-channel (lirc-get-channel-next lirc-current-channel))
291 (lirc-render-prompt))
292 (lirc-display-error "No channels joined.")))
298 (defun lirc-display-string (&rest strings)
299 (with-current-buffer (get-buffer-create "*lirc*")
301 (goto-char lirc-prompt-marker)
302 (let ((inhibit-read-only t)
303 (old-pos (marker-position lirc-prompt-marker))
304 (adaptive-fill-regexp (rx (= 6 anychar))))
305 (insert-before-markers
306 (propertize (concat (format-time-string "%H:%M") " ")
309 (propertize (concat (apply #'concat strings) "\n")
311 (fill-region old-pos lirc-prompt-marker)))))
313 (defun lirc-render-prompt ()
314 (with-current-buffer "*lirc*"
315 (let ((update-point (= lirc-input-marker (point)))
316 (update-window-points (mapcar (lambda (w)
317 (list (= (window-point w) lirc-input-marker)
319 (get-buffer-window-list nil nil t))))
321 (set-marker-insertion-type lirc-prompt-marker nil)
322 (set-marker-insertion-type lirc-input-marker t)
323 (let ((inhibit-read-only t))
324 (delete-region lirc-prompt-marker lirc-input-marker)
325 (goto-char lirc-prompt-marker)
327 (propertize (if lirc-current-context
332 (propertize lirc-prompt-string
336 (set-marker-insertion-type lirc-input-marker nil))
338 (goto-char lirc-input-marker))
339 (dolist (v update-window-points)
341 (set-window-point (cadr v) lirc-input-marker))))))
343 (defvar lirc-prompt-marker nil
344 "Marker for prompt position in LIRC buffer.")
346 (defvar lirc-input-marker nil
347 "Marker for prompt position in LIRC buffer.")
349 (defun lirc-setup-buffer ()
350 (with-current-buffer (get-buffer-create "*lirc*")
351 (if (markerp lirc-prompt-marker)
352 (set-marker lirc-prompt-marker (point-max))
353 (setq lirc-prompt-marker (point-max-marker)))
354 (if (markerp lirc-input-marker)
355 (set-marker lirc-input-marker (point-max))
356 (setq lirc-input-marker (point-max-marker)))
357 (goto-char (point-max))
358 (lirc-render-prompt)))
361 ;;; Output formatting
364 (defun lirc-display-message (from to text)
365 (let* ((to-type (lirc-get-context-type to))
366 (display-fun (cadr (assoc to-type lirc-context-table))))
367 (funcall display-fun from to text)))
369 (defun lirc-display-channel-message (from to text)
371 (propertize (concat to
377 (defun lirc-display-action (channel-name nick action)
378 (lirc-display-string (concat channel-name
380 (propertize (concat nick " " action)
383 (defun lirc-display-private-message (from to text)
387 (concat "[" from " -> " to "] "
392 (defun lirc-display-notice (&rest notices)
393 (lirc-display-string lirc-notice-prefix " " (apply #'concat notices)))
395 (defun lirc-display-error (&rest messages)
396 (lirc-display-string lirc-error-prefix " "
397 (propertize (apply #'concat messages)
400 ;;; Message evaluation
403 (defun lirc-eval-msg-string (string)
404 ;; (lirc-display-string string)
405 (let* ((msg (lirc-string->msg string)))
406 (pcase (lirc-msg-cmd msg)
409 (lirc-msg nil nil "PONG" (lirc-msg-params msg)))
410 (lirc-display-notice "ping-pong"))
413 (let* ((params (lirc-msg-params msg))
414 (channel (elt params 2))
415 (names (split-string (elt params 3))))
416 (lirc-add-context-users channel names)))
420 (lirc-as-string (length (lirc-get-context-users lirc-current-context)))
421 " users in " lirc-current-context))
423 ((rx (= 3 (any digit)))
424 (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " ")))
427 (guard (equal lirc-nick (lirc-msg-src msg))))
428 (let ((channel-name (car (lirc-msg-params msg))))
429 (lirc-add-context channel-name)
430 (setq lirc-current-context channel-name)
431 (lirc-display-notice "Joining channel " channel-name)
432 (lirc-render-prompt)))
435 (let ((channel-name (car (lirc-msg-params msg)))
436 (nick (lirc-msg-src msg)))
437 (lirc-add-context-users channel-name (list nick))
438 (lirc-display-notice nick " joined channel " channel-name)))
441 (guard (equal lirc-nick (lirc-msg-src msg))))
442 (let ((channel-name (car (lirc-msg-params msg))))
443 (lirc-display-notice "Left channel " channel-name)
444 (lirc-del-context channel-name)
445 (if (equal channel-name lirc-current-context)
446 (setq lirc-current-context (lirc-get-next-context)))
447 (lirc-render-prompt)))
450 (let ((channel-name (car (lirc-msg-params msg)))
451 (nick (lirc-msg-src msg)))
452 (lirc-del-context-user channel-name nick)
453 (lirc-display-notice nick " left channel " channel-name)))
456 (let ((nick (lirc-msg-src msg))
457 (reason (mapconcat 'identity (lirc-msg-params msg) " ")))
459 (lirc-display-notice nick " quit: " reason)))
462 (guard (equal lirc-nick (lirc-msg-src msg))))
463 (setq lirc-nick (car (lirc-msg-params msg)))
464 (lirc-display-notice "Set nick to " lirc-nick))
467 (let ((old-nick (lirc-msg-src msg))
468 (new-nick (car (lirc-msg-params msg))))
469 (lirc-display-notice nick " is now known as " new-nick)
470 (lirc-rename-user nick new-nick)))
473 (let ((nick (lirc-msg-src msg))
474 (channel (car (lirc-msg-params msg)))
475 (text (cadr (lirc-msg-params msg))))
477 ((rx (: "\01VERSION "
478 (let version (* (not "\01")))
480 (lirc-display-notice "CTCP version reply from " nick ": " version))
482 (lirc-display-notice text)))))
485 (let* ((from (lirc-msg-src msg))
486 (params (lirc-msg-params msg))
488 (text (cadr params)))
491 (let ((version-string (concat lirc-version " - running on GNU Emacs " emacs-version)))
492 (lirc-send-msg (lirc-msg nil nil "NOTICE"
493 (list from (concat "\01VERSION "
496 (lirc-display-notice "CTCP version request received from " from))
498 ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
499 (lirc-send-msg (lirc-msg nil nil "NOTICE" (list from ping)))
500 (lirc-display-notice "CTCP ping received from " from))
503 (lirc-display-notice "CTCP userinfo request from " from " (no response sent)"))
506 (lirc-display-message from to text)))))
508 (lirc-display-string (lirc-msg->string msg))))))
514 (defun lirc-enter-string (string)
515 (if (string-prefix-p "/" string)
516 (pcase (substring string 1)
517 ((rx (: "CONNECT " (let network (* not-newline))))
518 (lirc-display-notice "Connecting to " network "...")
519 (lirc-connect network))
521 ((rx (: "TOPIC " (let new-topic (* not-newline))))
522 (lirc-send-msg (lirc-msg nil nil "TOPIC" lirc-current-context new-topic)))
524 ((rx (: "ME " (let action (* not-newline))))
525 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
526 (list lirc-current-context
527 (concat "\01ACTION " action "\01"))))
528 (lirc-display-action lirc-nick action))
530 ((rx (: "VERSION" " " (let nick (* (not whitespace)))))
531 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
532 (list nick "\01VERSION\01")))
533 (lirc-display-notice "CTCP version request sent to " nick))
535 ((rx "PART" (opt (: " " (let channel (* not-newline)))))
536 (if (or lirc-current-context channel)
537 (lirc-send-msg (lirc-msg nil nil "PART" (if channel
539 lirc-current-context)))
540 (lirc-display-error "No current channel to leave.")))
543 (let to (* (not whitespace)))
545 (let text (* not-newline)))
546 (lirc-send-msg (lirc-msg nil nil "PRIVMSG" target text))
547 (lirc-display-message lirc-nick target text))
549 ((rx (: (let cmd-str (+ (not whitespace)))
550 (opt (: " " (let params-str (* not-newline))))))
551 (lirc-send-msg (lirc-msg nil nil (upcase cmd-str)
553 (split-string params-str)
556 (unless (string-empty-p string)
557 (if lirc-current-context
559 (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
562 (lirc-display-message lirc-nick lirc-current-context string))
563 (lirc-display-error "No current context.")))))
566 "Enter current contents of line after prompt."
568 (with-current-buffer "*lirc*"
570 (buffer-substring lirc-input-marker (point-max)))
571 (let ((inhibit-read-only t))
572 (delete-region lirc-input-marker (point-max)))))
578 (defvar lirc-mode-map
579 (let ((map (make-sparse-keymap)))
580 (define-key map (kbd "RET") 'lirc-enter)
581 ;; (define-key map (kbd "<C-tab>") 'lirc-cycle-channels)
584 (define-derived-mode lirc-mode text-mode "lirc"
585 "Major mode for LIRC.")
587 (when (fboundp 'evil-set-initial-state)
588 (evil-set-initial-state 'lirc-mode 'insert))
590 ;;; Main start procedure
594 "Switch to *lirc* buffer."
596 (if (get-buffer "*lirc*")
597 (switch-to-buffer "*lirc*")
598 (switch-to-buffer "*lirc*"))
605 ;;; lirc.el ends here