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