Cleanup and added sentinel for lirc process.
[lurk.git] / lirc.el
1 ;;; lirc.el --- Lightweight irc client  -*- lexical-binding:t -*-
2
3 ;; Copyright (C) 2021 Tim Vaughan
4
5 ;; Author: Tim Vaughan <timv@ughan.xyz>
6 ;; Created: 14 June 2021
7 ;; Version: 1.0
8 ;; Keywords: network
9 ;; Homepage: http://thelambdalab.xyz/erc
10 ;; Package-Requires: ((emacs "26"))
11
12 ;; This file is not part of GNU Emacs.
13
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.
18
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.
23
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/>.
26
27 ;;; Commentary:
28
29 ;;; Code:
30
31 (provide 'lirc)
32
33
34 ;;; Customizations
35 ;;
36
37 (defgroup lirc nil
38   "Lightweight IRC client."
39   :group 'network)
40
41 (defcustom lirc-nick "plugd"
42   "Default nick.")
43 (defcustom lirc-full-name "plugd"
44   "Default full name.")
45 (defcustom lirc-user-name "plugd"
46   "Default user name.")
47
48 (defcustom lirc-networks
49   '(("libera" "irc.libera.chat" 6697)
50     ("freenode" "chat.freenode.net" 6697)
51     ("local" "localhost" 6697))
52   "IRC networks.")
53
54 ;;; Faces
55 ;;
56
57 (defface lirc-text
58   '((t :inherit font-lock-preprocessor-face))
59   "Face used for Lirc text.")
60
61 (defface lirc-your-nick
62   '((t :inherit font-lock-constant-face))
63   "Face used for highlighting your nick.")
64
65 (defface lirc-prompt
66   '((t :inherit org-level-2))
67   "Face used for the prompt.")
68
69 (defface lirc-context
70   '((t :inherit org-list-dt))
71   "Face used for the context name in the prompt.")
72
73 (defface lirc-faded
74   '((t :inherit font-lock-preprocessor-face))
75   "Face used for faded Lirc text.")
76
77 (defface lirc-bold
78   '((t :inherit font-lock-function-name-face))
79   "Face used for bold Lirc text.")
80
81 (defface lirc-error
82   '((t :inherit font-lock-regexp-grouping-construct))
83   "Face used for Lirc error text.")
84
85 ;;; Global variables
86 ;;
87
88 (defvar lirc-version "Lirc v0.1")
89
90 (defvar lirc-notice-prefix
91   (concat
92    (propertize
93     "-" 'face 'lirc-faded)
94    (propertize
95     "!" 'face 'lirc-bold)
96    (propertize
97     "-" 'face 'lirc-faded)))
98
99 (defvar lirc-error-prefix
100   (propertize "!!!" 'face 'lirc-error))
101
102
103 (defvar lirc-prompt-string
104   (propertize "> " 'face 'lirc-prompt))
105
106
107 ;;; Network process
108 ;;
109
110 (defvar lirc-response "")
111
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))))
117
118 (defun lirc-sentinel (proc string)
119   (unless (equal "open" (string-trim string))
120     (lirc-display-error "Disconnected from server.")
121     (clrhash lirc-contexts)
122     (setq lirc-current-context nil)
123     (lirc-render-prompt)))
124   
125
126 (defun lirc-start-process (network)
127   (let* ((row (assoc network lirc-networks))
128          (host (elt row 1))
129          (port (elt row 2)))
130     (make-network-process :name "lirc"
131                           :host host
132                           :service port
133                           :filter #'lirc-filter
134                           :sentinel #'lirc-sentinel
135                           :nowait nil
136                           :tls-parameters (cons 'gnutls-x509pki
137                                                 (gnutls-boot-parameters
138                                                  :type 'gnutls-x509pki
139                                                  :hostname host))
140                           :buffer "*lirc*")))
141
142
143 (defun lirc-connect (network)
144   (if (get-process "lirc")
145       (lirc-display-error "Already connected.  Disconnect first.")
146     (if (not (assoc network lirc-networks))
147         (lirc-display-error "Network '" network "' is unknown.")
148       (clrhash lirc-contexts)
149       (setq lirc-current-context nil)
150       (lirc-start-process network)
151       (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name))
152       (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick)))))
153
154 (defun lirc-send-msg (msg)
155   (let ((proc (get-process "lirc")))
156     (if (and proc (eq (process-status proc) 'open))
157         (process-send-string proc (concat (lirc-msg->string msg) "\r\n"))
158       (lirc-display-error "No server connection established.")
159       (error "No server connection established"))))
160
161
162 ;;; Server messages
163 ;;
164
165 (defun lirc--as-string (obj)
166   (if obj
167       (with-output-to-string (princ obj))
168     nil))
169
170 (defun lirc-msg (tags src cmd &rest params)
171   (list (lirc--as-string tags)
172         (lirc--as-string src)
173         (upcase (lirc--as-string cmd))
174         (mapcar #'lirc--as-string
175                 (if (and params (listp (elt params 0)))
176                     (elt params 0)
177                   params))))
178
179 (defun lirc-msg-tags (msg) (elt msg 0))
180 (defun lirc-msg-src (msg) (elt msg 1))
181 (defun lirc-msg-cmd (msg) (elt msg 2))
182 (defun lirc-msg-params (msg) (elt msg 3))
183 (defun lirc-msg-trail (msg)
184   (let ((params (lirc-msg-params msg)))
185     (if params
186         (elt params (- (length params) 1)))))
187
188 (defvar lirc-msg-regex
189   (rx
190    (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
191         (* whitespace))
192    (opt (: ":" (: (group (* (not (any space "!" "@"))))
193                   (* (not (any space)))))
194         (* whitespace))
195    (group (: (* (not whitespace))))
196    (* whitespace)
197    (opt (group (+ not-newline))))
198   "Regex used to parse IRC messages.
199 Note that this regex is incomplete.  Noteably, we discard the non-nick
200 portion of the source component of the message, as LIRC doesn't use this.")
201
202 (defun lirc-string->msg (string)
203   (if (string-match lirc-msg-regex string)
204       (let* ((tags (match-string 1 string))
205              (src (match-string 2 string))
206              (cmd (upcase (match-string 3 string)))
207              (params-str (match-string 4 string))
208              (params
209               (if params-str
210                   (let* ((idx (cl-search ":" params-str))
211                          (l (split-string (string-trim (substring params-str 0 idx))))
212                          (r (if idx (list (substring params-str (+ 1 idx))) nil)))
213                     (append l r))
214                 nil)))
215         (apply #'lirc-msg (append (list tags src cmd) params)))
216     (error "Failed to parse string " string)))
217
218 (defun lirc--filtered-join (&rest args)
219   (string-join (seq-filter (lambda (el) el) args) " "))
220
221 (defun lirc-msg->string (msg)
222   (let ((tags (lirc-msg-tags msg))
223         (src (lirc-msg-src msg))
224         (cmd (lirc-msg-cmd msg))
225         (params (lirc-msg-params msg)))
226     (lirc--filtered-join
227      (if tags (concat "@" tags) nil)
228      (if src (concat ":" src) nil)
229      cmd
230      (if (> (length params) 1)
231          (string-join (seq-take params (- (length params) 1)) " ")
232        nil)
233      (if (> (length params) 0)
234          (concat ":" (elt params (- (length params) 1)))
235        nil))))
236
237
238 ;;; Contexts and users
239 ;;
240
241 (defvar lirc-context-table
242   '((channel lirc-display-channel-message)
243     (nick lirc-display-private-message)
244     (host lirc-diaplay-server-message)))
245
246 (defvar lirc-current-context nil)
247 (defvar lirc-contexts (make-hash-table :test #'equal))
248
249 (defun lirc-add-context (name)
250   (puthash name nil lirc-contexts))
251
252 (defun lirc-del-context (name)
253   (remhash name lirc-contexts))
254
255 (defun lirc-get-context-users (name)
256   (gethash name lirc-contexts))
257
258 (defun lirc-add-context-users (context users)
259   (puthash context
260            (append users
261                    (gethash context lirc-contexts))
262            lirc-contexts))
263
264 (defun lirc-del-context-user (context user)
265   (puthash context
266            (remove user (gethash context lirc-contexts))
267            lirc-contexts))
268
269 (defun lirc-del-user (user)
270   (dolist (context (lirc-get-context-list))
271     (lirc-del-context-user context user)))
272
273 (defun lirc-get-context-type (name)
274   (cond
275    ((string-prefix-p "#" name) 'channel)
276    ((string-match-p (rx (or "." "localhost")) name) 'host)
277    (t 'nick)))
278
279 (defun lirc-get-context-list ()
280   (let ((res nil))
281     (maphash (lambda (key val)
282                (cl-pushnew key res))
283              lirc-contexts)
284     res))
285
286 (defun lirc-get-next-context (&optional prev)
287   (if lirc-current-context
288       (let* ((context-list (if prev
289                                (reverse (lirc-get-context-list))
290                              (lirc-get-context-list)))
291              (context-list* (member lirc-current-context context-list)))
292         (if (> (length context-list*) 1)
293             (cadr context-list*)
294           (car context-list)))
295     nil))
296
297 (defun lirc-cycle-contexts (&optional rev)
298   (if lirc-current-context
299       (progn
300         (setq lirc-current-context (lirc-get-next-context rev))
301         (lirc-render-prompt))
302     (lirc-display-error "No channels joined.")))
303
304 (defun lirc-cycle-contexts-forward ()
305   (interactive)
306   (lirc-cycle-contexts))
307
308 (defun lirc-cycle-contexts-reverse ()
309   (interactive)
310   (lirc-cycle-contexts t))
311
312 ;;; Buffer
313 ;;
314
315 (defun lirc-display-string (&rest strings)
316   (with-current-buffer (get-buffer-create "*lirc*")
317     (save-excursion
318       (goto-char lirc-prompt-marker)
319       (let ((inhibit-read-only t)
320             (old-pos (marker-position lirc-prompt-marker))
321             (adaptive-fill-regexp (rx (= 6 anychar))))
322         (insert-before-markers
323          (propertize (concat (format-time-string "%H:%M") " ")
324                      'face 'lirc-text
325                      'read-only t)
326          (propertize (concat (apply #'concat strings) "\n")
327                      'read-only t))
328         (fill-region old-pos lirc-prompt-marker)))))
329
330 (defun lirc-render-prompt ()
331   (with-current-buffer "*lirc*"
332     (let ((update-point (= lirc-input-marker (point)))
333           (update-window-points (mapcar (lambda (w)
334                                           (list (= (window-point w) lirc-input-marker)
335                                                 w))
336                                         (get-buffer-window-list nil nil t))))
337       (save-excursion
338         (set-marker-insertion-type lirc-prompt-marker nil)
339         (set-marker-insertion-type lirc-input-marker t)
340         (let ((inhibit-read-only t))
341           (delete-region lirc-prompt-marker lirc-input-marker)
342           (goto-char lirc-prompt-marker)
343           (insert
344            (propertize (if lirc-current-context
345                            lirc-current-context
346                          "")
347                        'face 'lirc-context
348                        'read-only t)
349            (propertize lirc-prompt-string
350                        'face 'lirc-prompt
351                        'read-only t
352                        'rear-nonsticky t)))
353         (set-marker-insertion-type lirc-input-marker nil))
354       (if update-point
355           (goto-char lirc-input-marker))
356       (dolist (v update-window-points)
357         (if (car v)
358             (set-window-point (cadr v) lirc-input-marker))))))
359   
360 (defvar lirc-prompt-marker nil
361   "Marker for prompt position in LIRC buffer.")
362
363 (defvar lirc-input-marker nil
364   "Marker for prompt position in LIRC buffer.")
365
366 (defun lirc-setup-buffer ()
367   (with-current-buffer (get-buffer-create "*lirc*")
368     (if (markerp lirc-prompt-marker)
369         (set-marker lirc-prompt-marker (point-max))
370       (setq lirc-prompt-marker (point-max-marker)))
371     (if (markerp lirc-input-marker)
372         (set-marker lirc-input-marker (point-max))
373       (setq lirc-input-marker (point-max-marker)))
374     (goto-char (point-max))
375     (lirc-render-prompt)))
376
377
378 ;;; Output formatting
379 ;;
380
381 (defun lirc-display-message (from to text)
382   (let* ((to-type (lirc-get-context-type to))
383          (display-fun (cadr (assoc to-type lirc-context-table))))
384     (funcall display-fun from to text)))
385
386 (defun lirc-display-channel-message (from to text)
387   (lirc-display-string
388    (propertize (concat to
389                        " <" from "> "
390                        text)
391                'face 'lirc-text)))
392                
393
394 (defun lirc-display-action (channel-name nick action)
395   (lirc-display-string (concat channel-name
396                                " * "
397                                (propertize (concat nick " " action)
398                                            'face 'lirc-text))))
399
400 (defun lirc-display-private-message (from to text)
401   (lirc-display-string
402    (concat
403     (propertize
404      (concat "[" from " -> " to "] "
405              text)
406      'face 'lirc-text))))
407         
408
409 (defun lirc-display-notice (&rest notices)
410   (lirc-display-string lirc-notice-prefix " " (apply #'concat notices)))
411
412 (defun lirc-display-error (&rest messages)
413   (lirc-display-string lirc-error-prefix " "
414                        (propertize (apply #'concat messages)
415                                    'face 'lirc-error)))
416
417 ;;; Message evaluation
418 ;;
419
420 (defun lirc-eval-msg-string (string)
421   ;; (lirc-display-string string)
422   (let* ((msg (lirc-string->msg string)))
423     (pcase (lirc-msg-cmd msg)
424       ("PING"
425        (lirc-send-msg
426         (lirc-msg nil nil "PONG" (lirc-msg-params msg)))
427        (lirc-display-notice "ping-pong"))
428
429       ("353" ; NAMEREPLY
430        (let* ((params (lirc-msg-params msg))
431               (channel (elt params 2))
432               (names (split-string (elt params 3))))
433          (lirc-add-context-users channel names)))
434
435       ("366" ; ENDOFNAMES
436        (lirc-display-notice
437         (lirc-as-string (length (lirc-get-context-users lirc-current-context)))
438         " users in " lirc-current-context))
439
440       ((rx (= 3 (any digit)))
441        (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " ")))
442
443       ((and "JOIN"
444             (guard (equal lirc-nick (lirc-msg-src msg))))
445        (let ((channel-name (car (lirc-msg-params msg))))
446          (lirc-add-context channel-name)
447          (setq lirc-current-context channel-name)
448          (lirc-display-notice "Joining channel " channel-name)
449          (lirc-render-prompt)))
450
451       ("JOIN"
452        (let ((channel-name (car (lirc-msg-params msg)))
453              (nick (lirc-msg-src msg)))
454          (lirc-add-context-users channel-name (list nick))
455          (lirc-display-notice nick " joined channel " channel-name)))
456
457       ((and "PART"
458             (guard (equal lirc-nick (lirc-msg-src msg))))
459        (let ((channel-name (car (lirc-msg-params msg))))
460          (lirc-display-notice "Left channel " channel-name)
461          (lirc-del-context channel-name)
462          (if (equal channel-name lirc-current-context)
463              (setq lirc-current-context (lirc-get-next-context)))
464          (lirc-render-prompt)))
465
466       ("PART"
467        (let ((channel-name (car (lirc-msg-params msg)))
468              (nick (lirc-msg-src msg)))
469          (lirc-del-context-user channel-name nick)
470          (lirc-display-notice nick " left channel " channel-name)))
471
472       ("QUIT"
473        (let ((nick (lirc-msg-src msg))
474              (reason (mapconcat 'identity (lirc-msg-params msg) " ")))
475          (lirc-del-user nick)
476          (lirc-display-notice nick " quit: " reason)))
477
478       ((and "NICK"
479             (guard (equal lirc-nick (lirc-msg-src msg))))
480        (setq lirc-nick (car (lirc-msg-params msg)))
481        (lirc-display-notice "Set nick to " lirc-nick))
482
483       ("NICK"
484        (let ((old-nick (lirc-msg-src msg))
485              (new-nick (car (lirc-msg-params msg))))
486          (lirc-display-notice nick " is now known as " new-nick)
487          (lirc-rename-user nick new-nick)))
488
489       ("NOTICE"
490        (let ((nick (lirc-msg-src msg))
491              (channel (car (lirc-msg-params msg)))
492              (text (cadr (lirc-msg-params msg))))
493          (pcase text
494            ((rx (: "\01VERSION "
495                    (let version (* (not "\01")))
496                    "\01"))
497             (lirc-display-notice "CTCP version reply from " nick ": " version))
498            (_
499             (lirc-display-notice text)))))
500
501       ("PRIVMSG"
502        (let* ((from (lirc-msg-src msg))
503               (params (lirc-msg-params msg))
504               (to (car params))
505               (text (cadr params)))
506          (pcase text
507            ("\01VERSION\01"
508             (let ((version-string (concat lirc-version " - running on GNU Emacs " emacs-version)))
509               (lirc-send-msg (lirc-msg nil nil "NOTICE"
510                                        (list from (concat "\01VERSION "
511                                                           version-string
512                                                           "\01")))))
513             (lirc-display-notice "CTCP version request received from " from))
514
515            ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
516             (lirc-send-msg (lirc-msg nil nil "NOTICE" (list from ping)))
517             (lirc-display-notice "CTCP ping received from " from))
518
519            ("\01USERINFO\01"
520             (lirc-display-notice "CTCP userinfo request from " from " (no response sent)"))
521
522            (_
523             (lirc-display-message from to text)))))
524       (_
525        (lirc-display-string (lirc-msg->string msg))))))
526
527
528 ;;; Command entering
529 ;;
530
531 (defun lirc-enter-string (string)
532   (if (string-prefix-p "/" string)
533       (pcase (substring string 1)
534         ((rx (: "CONNECT " (let network (* not-newline))))
535          (lirc-display-notice "Attempting to connect to " network "...")
536          (lirc-connect network))
537
538         ((rx (: "TOPIC " (let new-topic (* not-newline))))
539          (lirc-send-msg (lirc-msg nil nil "TOPIC" lirc-current-context new-topic)))
540
541         ((rx (: "ME " (let action (* not-newline))))
542          (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
543                                   (list lirc-current-context
544                                         (concat "\01ACTION " action "\01"))))
545          (lirc-display-action lirc-nick action))
546
547         ((rx (: "VERSION" " " (let nick (* (not whitespace)))))
548          (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
549                                   (list nick "\01VERSION\01")))
550          (lirc-display-notice "CTCP version request sent to " nick))
551
552         ((rx "PART" (opt (: " " (let channel (* not-newline)))))
553          (if (or lirc-current-context channel)
554              (lirc-send-msg (lirc-msg nil nil "PART" (if channel
555                                                          channel
556                                                        lirc-current-context)))
557            (lirc-display-error "No current channel to leave.")))
558
559         ((rx "MSG "
560              (let to (* (not whitespace)))
561              " "
562              (let text (* not-newline)))
563          (lirc-send-msg (lirc-msg nil nil "PRIVMSG" to text))
564          (lirc-display-message lirc-nick to text))
565
566         ((rx (: (let cmd-str (+ (not whitespace)))
567                 (opt (: " " (let params-str (* not-newline))))))
568          (lirc-send-msg (lirc-msg nil nil (upcase cmd-str)
569                                   (if params-str
570                                       (split-string params-str)
571                                     nil)))))
572
573     (unless (string-empty-p string)
574       (if lirc-current-context
575           (progn
576             (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
577                                      lirc-current-context
578                                      string))
579             (lirc-display-message lirc-nick lirc-current-context string))
580         (lirc-display-error "No current context.")))))
581
582 (defun lirc-enter ()
583   "Enter current contents of line after prompt."
584   (interactive)
585   (with-current-buffer "*lirc*"
586     (lirc-enter-string
587      (buffer-substring lirc-input-marker (point-max)))
588     (let ((inhibit-read-only t))
589       (delete-region lirc-input-marker (point-max)))))
590
591
592 ;;; Mode
593 ;;
594
595 (defvar lirc-mode-map
596   (let ((map (make-sparse-keymap)))
597     (define-key map (kbd "RET") 'lirc-enter)
598     (define-key map (kbd "<C-tab>") 'lirc-cycle-contexts-forward)
599     (define-key map (kbd "<C-S-tab>") 'lirc-cycle-contexts-reverse)
600     map))
601
602 (define-derived-mode lirc-mode text-mode "lirc"
603   "Major mode for LIRC.")
604
605 (when (fboundp 'evil-set-initial-state)
606   (evil-set-initial-state 'lirc-mode 'insert))
607
608 ;;; Main start procedure
609 ;;
610
611 (defun lirc ()
612   "Switch to *lirc* buffer."
613   (interactive)
614   (if (get-buffer "*lirc*")
615       (switch-to-buffer "*lirc*")
616     (switch-to-buffer "*lirc*"))
617   (lirc-mode)
618   (lirc-setup-buffer)
619   "Started LIRC.")
620
621
622
623 ;;; lirc.el ends here