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