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 (defcustom lirc-host "localhost"
  47   "Default server.")
  48 (defcustom lirc-port 6667
  49   "Default port.")
  50
  51 (defcustom lirc-prompt-string "> "
  52   "Prompt.")
  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-channel
  70   '((t :inherit org-list-dt))
  71   "Face used for the channel name in the prompt.")
  72
  73 ;;; Global variables
  74 ;;
  75
  76 (defvar lirc-version "Lirc v0.1")
  77
  78
  79 ;;; Network process
  80 ;;
  81
  82 (defvar lirc-response "")
  83
  84 (defun lirc-filter (proc string)
  85   (dolist (line (split-string (concat lirc-response string) "\n"))
  86     (if (string-suffix-p "\r" line)
  87         (lirc-eval-msg-string (string-trim line))
  88       (setq lirc-response line))))
  89
  90 (defun lirc-get-process ()
  91   (let ((proc (get-process "lirc")))
  92     (if (and proc (eq (process-status proc) 'open))
  93         proc
  94       (make-network-process :name "lirc"
  95                             :host lirc-host
  96                             :service lirc-port
  97                             :filter #'lirc-filter
  98                             :nowait t
  99                             :buffer "*lirc*"))))
 100
 101 ;;; Messages
 102 ;;
 103
 104 (defun lirc-as-string (obj)
 105   (if obj
 106       (with-output-to-string (princ obj))
 107     nil))
 108
 109 (defun lirc-msg (tags src cmd &rest params)
 110   (list (lirc-as-string tags)
 111         (lirc-as-string src)
 112         (upcase (lirc-as-string cmd))
 113         (mapcar #'lirc-as-string
 114                 (if (and params (listp (elt params 0)))
 115                     (elt params 0)
 116                   params))))
 117
 118 (defun lirc-msg-tags (msg) (elt msg 0))
 119 (defun lirc-msg-src (msg) (elt msg 1))
 120 (defun lirc-msg-cmd (msg) (elt msg 2))
 121 (defun lirc-msg-params (msg) (elt msg 3))
 122 (defun lirc-msg-trail (msg)
 123   (let ((params (lirc-msg-params msg)))
 124     (if params
 125         (elt params (- (length params) 1)))))
 126
 127 (defvar lirc-msg-regex
 128   (rx
 129    (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
 130         (* whitespace))
 131    (opt (: ":" (: (group (* (not (any space "!" "@"))))
 132                   (* (not (any space)))))
 133         (* whitespace))
 134    (group (: (* (not whitespace))))
 135    (* whitespace)
 136    (opt (group (+ not-newline))))
 137   "Regex used to parse IRC messages.
 138 Note that this regex is incomplete.  Noteably, we discard the non-nick
 139 portion of the source component of the message, as LIRC doesn't use this.")
 140
 141 (defun lirc-string->msg (string)
 142   (if (string-match lirc-msg-regex string)
 143       (let* ((tags (match-string 1 string))
 144              (src (match-string 2 string))
 145              (cmd (upcase (match-string 3 string)))
 146              (params-str (match-string 4 string))
 147              (params
 148               (if params-str
 149                   (let* ((idx (cl-search ":" params-str))
 150                          (l (split-string (string-trim (substring params-str 0 idx))))
 151                          (r (if idx (list (substring params-str (+ 1 idx))) nil)))
 152                     (append l r))
 153                 nil)))
 154         (apply #'lirc-msg (append (list tags src cmd) params)))
 155     (error "Failed to parse string " string)))
 156
 157 (defun lirc--filtered-join (&rest args)
 158   (string-join (seq-filter (lambda (el) el) args) " "))
 159
 160 (defun lirc-msg->string (msg)
 161   (let ((tags (lirc-msg-tags msg))
 162         (src (lirc-msg-src msg))
 163         (cmd (lirc-msg-cmd msg))
 164         (params (lirc-msg-params msg)))
 165     (lirc--filtered-join
 166      (if tags (concat "@" tags) nil)
 167      (if src (concat ":" src) nil)
 168      cmd
 169      (if (> (length params) 1)
 170          (string-join (seq-take params (- (length params) 1)) " ")
 171        nil)
 172      (if (> (length params) 0)
 173          (concat ":" (elt params (- (length params) 1)))
 174        nil))))
 175
 176
 177 ;;; Channels
 178 ;;
 179
 180 (defvar lirc-current-channel nil)
 181 (defvar lirc-channel-list nil)
 182
 183 (defun lirc-add-channel (channel-name)
 184   (add-to-list 'lirc-channel-list
 185                (list channel-name)))
 186
 187 (defun lirc-del-channel (channel-name)
 188   (setq lirc-channel-list
 189         (assoc-delete-all channel-name lirc-channel-list)))
 190
 191 (defun lirc-get-channel-users (channel-name)
 192   (cdr (assoc channel-name lirc-channel-list)))
 193
 194 (defun lirc-set-channel-users (channel-name users)
 195   (setcdr (assoc channel-name lirc-channel-list) users))
 196
 197 (defun lirc-add-channel-users (channel-name &rest users)
 198   (let ((current-users (lirc-get-channel-users channel-name)))
 199     (lirc-set-channel-users channel-name (append users current-users))))
 200
 201 (defun lirc-del-channel-users (channel-name &rest users)
 202   (let ((current-users (lirc-get-channel-users channel-name)))
 203     (lirc-set-channel-users channel-name
 204                             (cl-set-difference current-users users :test #'equal))))
 205
 206
 207 ;;; Buffer
 208 ;;
 209
 210 (defun lirc-display-string (&rest strings)
 211   (with-current-buffer (get-buffer-create "*lirc*")
 212     (save-excursion
 213       (goto-char lirc-prompt-marker)
 214       (let ((inhibit-read-only t))
 215         (insert-before-markers
 216          (propertize (concat (format-time-string "%H:%M") " ")
 217                      'face 'lirc-text
 218                      'read-only t)
 219          (propertize (concat (apply #'concat strings) "\n")
 220                      'read-only t))))))
 221
 222 (defun lirc-connect ()
 223   (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name))
 224   (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick)))
 225
 226 (defun lirc-send-msg (msg)
 227   (let ((proc (lirc-get-process)))
 228     (process-send-string proc (concat (lirc-msg->string msg) "\r\n"))))
 229
 230 (defun lirc-render-prompt ()
 231   (with-current-buffer "*lirc*"
 232     (set-marker-insertion-type lirc-prompt-marker nil)
 233     (set-marker-insertion-type lirc-input-marker t)
 234     (save-excursion
 235       (let ((inhibit-read-only t))
 236         (delete-region lirc-prompt-marker lirc-input-marker)
 237         (goto-char lirc-prompt-marker)
 238         (insert
 239          (propertize (if lirc-current-channel
 240                          lirc-current-channel
 241                        "[no channel]")
 242                      'face 'lirc-channel
 243                      'read-only t)
 244          (propertize lirc-prompt-string
 245                      'face 'lirc-prompt
 246                      'read-only t
 247                      'rear-nonsticky t)))))
 248   (set-marker-insertion-type lirc-input-marker nil))
 249
 250 (defvar lirc-prompt-marker nil
 251   "Marker for prompt position in LIRC buffer.")
 252
 253 (defvar lirc-input-marker nil
 254   "Marker for prompt position in LIRC buffer.")
 255
 256 (defun lirc-setup-buffer ()
 257   (with-current-buffer (get-buffer-create "*lirc*")
 258     (if (markerp lirc-prompt-marker)
 259         (set-marker lirc-prompt-marker (point-max))
 260       (setq lirc-prompt-marker (point-max-marker)))
 261     (if (markerp lirc-input-marker)
 262         (set-marker lirc-input-marker (point-max))
 263       (setq lirc-input-marker (point-max-marker)))
 264     (lirc-render-prompt)
 265     (goto-char (point-max))
 266     (recenter -1)))
 267
 268
 269 ;;; Output formatting
 270 ;;
 271
 272 (defun lirc-display-action (channel nick action)
 273   (lirc-display-string (concat " * "
 274                                (propertize (concat nick " " action)
 275                                            'face 'lirc-text))))
 276
 277 (defun lirc-display-message (channel nick message)
 278   (lirc-display-string
 279    (concat
 280     (propertize (concat channel " ")
 281                 'face 'lirc-text)
 282     (propertize (concat "<" nick "> ")
 283                 'face
 284                 (if (equal nick lirc-nick)
 285                     'lirc-your-nick
 286                   'lirc-text))
 287     (propertize message 'face 'lirc-text))))
 288
 289 (defun lirc-display-notice (&rest notices)
 290   (lirc-display-string "*** " (apply #'concat notices)))
 291
 292 ;;; Message evaluation
 293 ;;
 294
 295 (defun lirc-eval-msg-string (string)
 296   ;; (lirc-display-string string)
 297   (let* ((msg (lirc-string->msg string)))
 298     (pcase (lirc-msg-cmd msg)
 299       ("PING"
 300        (lirc-send-msg
 301         (lirc-msg nil nil "PONG" (lirc-msg-params msg))))
 302
 303       ("353" ; NAMEREPLY
 304        (let* ((params (lirc-msg-params msg))
 305               (channel (elt params 2))
 306               (names (split-string (elt params 3))))
 307          (apply #'lirc-add-channel-users (cons channel names))))
 308
 309       ((rx (= 3 (any digit)))
 310        (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " ")))
 311
 312       ((and "JOIN"
 313             (guard (equal lirc-nick (lirc-msg-src msg))))
 314        (let ((channel (car (lirc-msg-params msg))))
 315          (setq lirc-current-channel channel)
 316          (lirc-add-channel channel)
 317          (lirc-render-prompt)))
 318
 319       ("JOIN"
 320        (let ((channel (car (lirc-msg-params msg)))
 321              (nick (lirc-msg-src msg)))
 322          (lirc-add-channel-users channel nick)))
 323
 324       ((and "PART"
 325             (guard (equal lirc-nick (lirc-msg-src msg))))
 326        (setq lirc-current-channel nil)
 327        (lirc-del-channel (car (lirc-msg-params msg)))
 328        (lirc-render-prompt))
 329
 330       ("PART"
 331        (let ((channel (car (lirc-msg-params msg)))
 332              (nick (lirc-msg-src msg)))
 333          (lirc-del-channel-users channel nick)
 334          (lirc-display-notice nick " left channel " channel)))
 335
 336       ("QUIT"
 337        (let ((nick (lirc-msg-src msg))
 338              (reason (mapconcat 'identity (lirc-msg-params msg) " ")))
 339          (lirc-del-users nick)
 340          (lirc-display-notice nick " quit: " reason)))
 341
 342       ((and "NICK"
 343             (guard (equal lirc-nick (lirc-msg-src msg))))
 344        (setq lirc-nick (car (lirc-msg-params msg)))
 345        (lirc-display-notice "Set nick to " lirc-nick))
 346
 347       ("NOTICE"
 348        (let ((nick (lirc-msg-src msg))
 349              (channel (car (lirc-msg-params msg)))
 350              (text (cadr (lirc-msg-params msg))))
 351          (pcase text
 352            ((rx (: "\01VERSION "
 353                    (let version (* (not "\01")))
 354                    "\01"))
 355             (lirc-display-notice "CTCP version reply from " nick ": " version)))))
 356
 357       ("PRIVMSG"
 358        (let ((nick (lirc-msg-src msg))
 359              (channel (car (lirc-msg-params msg)))
 360              (text (cadr (lirc-msg-params msg))))
 361          (pcase text
 362            ((rx (: "\01ACTION "
 363                    (let action (* (not "\01")))
 364                    "\01"))
 365             (lirc-display-action nick action))
 366
 367            ("\01VERSION\01"
 368             (let ((version-string (concat lirc-version " - running on GNU Emacs " emacs-version)))
 369               (lirc-send-msg (lirc-msg nil nil "NOTICE"
 370                                        (list nick (concat "\01VERSION "
 371                                                           version-string
 372                                                           "\01")))))
 373             (lirc-display-notice "CTCP version request received from " nick))
 374
 375            ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
 376             (lirc-send-msg (lirc-msg nil nil "NOTICE" (list nick ping)))
 377             (lirc-display-notice "CTCP ping received from " nick))
 378
 379            ("\01USERINFO\01"
 380             (lirc-display-notice "CTCP userinfo request from " nick " (no response sent)"))
 381
 382            (_
 383             (lirc-display-message channel nick text)))))
 384       (_
 385        (lirc-display-string (lirc-msg->string msg))))))
 386
 387
 388 ;;; Command entering
 389 ;;
 390
 391 (defun lirc-enter-string (string)
 392   (if (string-prefix-p "/" string)
 393       (pcase (substring string 1)
 394         ((rx (: "TOPIC" " " (let new-topic (* not-newline))))
 395          (lirc-send-msg (lirc-msg nil nil "TOPIC" lirc-current-channel new-topic)))
 396
 397         ((rx (: "me" " " (let action (* not-newline))))
 398          (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
 399                                   (list lirc-current-channel
 400                                         (concat "\01ACTION " action "\01"))))
 401          (lirc-display-action lirc-nick action))
 402
 403         ((rx (: "VERSION" " " (let nick (* (not whitespace)))))
 404          (lirc-send-msg (lirc-msg nil nil "PRIVMSG"
 405                                   (list nick "\01VERSION\01")))
 406          (lirc-display-notice "CTCP version request sent to " nick))
 407
 408         ((rx "PART")
 409          (lirc-send-msg (lirc-msg nil nil "PART" lirc-current-channel)))
 410
 411         ((rx (: (let cmd-str (+ (not whitespace)))
 412                 (opt (: " " (let params-str (* not-newline))))))
 413          (lirc-send-msg (lirc-msg nil nil (upcase cmd-str)
 414                                   (if params-str
 415                                       (split-string params-str)
 416                                     nil)))))
 417
 418     (unless (string-empty-p string)
 419       (lirc-send-msg (lirc-msg nil nil "PRIVMSG" lirc-current-channel string))
 420       (lirc-display-message lirc-current-channel lirc-nick string))))
 421
 422 (defun lirc-enter ()
 423   "Enter current contents of line after prompt."
 424   (interactive)
 425   (with-current-buffer "*lirc*"
 426     (lirc-enter-string
 427      (buffer-substring lirc-input-marker (point-max)))
 428     (let ((inhibit-read-only t))
 429       (delete-region lirc-input-marker (point-max)))))
 430
 431
 432
 433 ;;; Mode
 434 ;;
 435
 436 (defvar lirc-mode-map
 437   (let ((map (make-sparse-keymap)))
 438     (define-key map (kbd "RET") 'lirc-enter)
 439     map))
 440
 441 (define-derived-mode lirc-mode text-mode "lirc"
 442   "Major mode for LIRC.")
 443
 444 (when (fboundp 'evil-set-initial-state)
 445   (evil-set-initial-state 'lirc-mode 'insert))
 446
 447 ;;; Main start procedure
 448 ;;
 449
 450 (defun lirc ()
 451   "Switch to *lirc* buffer."
 452   (interactive)
 453   (if (get-buffer "*lirc*")
 454       (switch-to-buffer "*lirc*")
 455     (switch-to-buffer "*lirc*"))
 456   (lirc-mode)
 457   (lirc-setup-buffer)
 458   (lirc-connect)
 459   "Started LIRC.")
 460
 461
 462
 463 ;;; lirc.el ends here