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-prompt
  58   '((t :inherit org-level-2))
  59   "Face used for the prompt.")
  60
  61 (defface lirc-channel
  62   '((t :inherit org-list-dt))
  63   "Face used for the channel name in the prompt.")
  64
  65 ;;; Global variables
  66 ;;
  67
  68
  69 ;;; Network process
  70 ;;
  71
  72 (defvar lirc-response "")
  73
  74 (defun lirc-filter (proc string)
  75   (dolist (line (split-string (concat lirc-response string) "\n"))
  76     (if (string-suffix-p "\r" line)
  77         (lirc-eval-msg-string (string-trim line))
  78       (setq lirc-response line))))
  79
  80 (defun lirc-get-process ()
  81   (let ((proc (get-process "lirc")))
  82     (if (and proc (eq (process-status proc) 'open))
  83         proc
  84       (make-network-process :name "lirc"
  85                             :host lirc-host
  86                             :service lirc-port
  87                             :filter #'lirc-filter
  88                             :nowait t
  89                             :buffer "*lirc*"))))
  90
  91 ;;; Messages
  92 ;;
  93
  94 (defun lirc-as-string (obj)
  95   (if obj
  96       (with-output-to-string (princ obj))
  97     nil))
  98
  99 (defun lirc-msg (tags src cmd &rest params)
 100   (list (lirc-as-string tags)
 101         (lirc-as-string src)
 102         (upcase (lirc-as-string cmd))
 103         (mapcar #'lirc-as-string
 104                 (if (and params (listp (elt params 0)))
 105                     (elt params 0)
 106                   params))))
 107
 108 (defun lirc-msg-tags (msg) (elt msg 0))
 109 (defun lirc-msg-src (msg) (elt msg 1))
 110 (defun lirc-msg-cmd (msg) (elt msg 2))
 111 (defun lirc-msg-params (msg) (elt msg 3))
 112 (defun lirc-msg-trail (msg)
 113   (let ((params (lirc-msg-params msg)))
 114     (if params
 115         (elt params (- (length params) 1)))))
 116
 117 (defvar lirc-msg-regex
 118   (rx
 119    (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
 120         (* whitespace))
 121    (opt (: ":" (: (group (* (not (any space "!" "@"))))
 122                   (* (not (any space)))))
 123         (* whitespace))
 124    (group (: (* (not whitespace))))
 125    (* whitespace)
 126    (opt (group (+ not-newline))))
 127   "Regex used to parse IRC messages.
 128 Note that this regex is incomplete.  Noteably, we discard the non-nick
 129 portion of the source component of the message, as LIRC doesn't use this.")
 130
 131 (defun lirc-string->msg (string)
 132   (if (string-match lirc-msg-regex string)
 133       (let* ((tags (match-string 1 string))
 134              (src (match-string 2 string))
 135              (cmd (upcase (match-string 3 string)))
 136              (params-str (match-string 4 string))
 137              (params
 138               (if params-str
 139                   (let* ((idx (cl-search ":" params-str))
 140                          (l (split-string (string-trim (substring params-str 0 idx))))
 141                          (r (if idx (list (substring params-str (+ 1 idx))) nil)))
 142                     (append l r))
 143                 nil)))
 144         (apply #'lirc-msg (append (list tags src cmd) params)))
 145     (error "Failed to parse string " string)))
 146
 147 (defun lirc--filtered-join (&rest args)
 148   (string-join (seq-filter (lambda (el) el) args) " "))
 149
 150 (defun lirc-msg->string (msg)
 151   (let ((tags (lirc-msg-tags msg))
 152         (src (lirc-msg-src msg))
 153         (cmd (lirc-msg-cmd msg))
 154         (params (lirc-msg-params msg)))
 155     (lirc--filtered-join
 156      (if tags (concat "@" tags) nil)
 157      (if src (concat ":" src) nil)
 158      cmd
 159      (if (> (length params) 1)
 160          (string-join (seq-take params (- (length params) 1)) " ")
 161        nil)
 162      (if (> (length params) 0)
 163          (concat ":" (elt params (- (length params) 1)))
 164        nil))))
 165
 166
 167 ;;; Channels
 168 ;;
 169
 170 (defvar lirc-current-channel nil)
 171 (defvar lirc-channel-list nil)
 172
 173 (defun lirc-add-channel (channel-name)
 174   (add-to-list 'lirc-channel-list
 175                (list channel-name)))
 176
 177 (defun lirc-del-channel (channel-name)
 178   (setq lirc-channel-list
 179         (assoc-delete-all channel-name lirc-channel-list)))
 180
 181 (defun lirc-get-channel-users (channel-name)
 182   (cdr (assoc channel-name lirc-channel-list)))
 183
 184 (defun lirc-set-channel-users (channel-name users)
 185   (setcdr (assoc channel-name lirc-channel-list) users))
 186
 187 (defun lirc-add-channel-users (channel-name &rest users)
 188   (let ((current-users (lirc-get-channel-users channel-name)))
 189     (lirc-set-channel-users channel-name (append users current-users))))
 190
 191 (defun lirc-del-channel-users (channel-name &rest users)
 192   (let ((current-users (lirc-get-channel-users channel-name)))
 193     (lirc-channel-set-users channel-name
 194                             (cl-set-difference current-users users :test #'equal))))
 195
 196
 197 ;;; Buffer
 198 ;;
 199
 200 (defun lirc-display-string (string)
 201   (with-current-buffer (get-buffer-create "*lirc*")
 202     (save-excursion
 203       (goto-char lirc-prompt-marker)
 204       (let ((inhibit-read-only t))
 205         (insert-before-markers (propertize (concat string "\n") 'read-only t))))))
 206
 207 (defun lirc-connect ()
 208   (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name))
 209   (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick)))
 210
 211 (defun lirc-send-msg (msg)
 212   (let ((proc (lirc-get-process)))
 213     (process-send-string proc (concat (lirc-msg->string msg) "\r\n"))))
 214
 215 (defun lirc-render-prompt ()
 216   (with-current-buffer "*lirc*"
 217     (set-marker-insertion-type lirc-prompt-marker nil)
 218     (set-marker-insertion-type lirc-input-marker t)
 219     (save-excursion
 220       (let ((inhibit-read-only t))
 221         (delete-region lirc-prompt-marker lirc-input-marker)
 222         (goto-char lirc-prompt-marker)
 223         (insert
 224          (propertize (if lirc-current-channel
 225                          lirc-current-channel
 226                        "[no channel]")
 227                      'face 'lirc-channel
 228                      'read-only t)
 229          (propertize lirc-prompt-string
 230                      'face 'lirc-prompt
 231                      'read-only t
 232                      'rear-nonsticky t)))))
 233   (set-marker-insertion-type lirc-input-marker nil))
 234
 235 (defvar lirc-prompt-marker nil
 236   "Marker for prompt position in LIRC buffer.")
 237
 238 (defvar lirc-input-marker nil
 239   "Marker for prompt position in LIRC buffer.")
 240
 241 (defun lirc-setup-buffer ()
 242   (with-current-buffer (get-buffer-create "*lirc*")
 243     (if (markerp lirc-prompt-marker)
 244         (set-marker lirc-prompt-marker (point-max))
 245       (setq lirc-prompt-marker (point-max-marker)))
 246     (if (markerp lirc-input-marker)
 247         (set-marker lirc-input-marker (point-max))
 248       (setq lirc-input-marker (point-max-marker)))
 249     (lirc-render-prompt)
 250     (goto-char (point-max))
 251     (recenter -1)))
 252
 253 ;;; Message evaluation
 254 ;;
 255
 256 (defun lirc-eval-msg-string (string)
 257   (lirc-display-string string)
 258   (let* ((msg (lirc-string->msg string)))
 259     (pcase (lirc-msg-cmd msg)
 260       ("PING"
 261        (lirc-send-msg
 262         (lirc-msg nil nil "PONG" (lirc-msg-params msg))))
 263       ;; ((rx (= 3 digit))
 264       ;;  (lirc-display-string (string-join (cdr (lirc-msg-params msg)) " ")))
 265
 266       ("353" ; NAMEREPLY
 267        (let* ((params (lirc-msg-params msg))
 268               (channel (elt params 2))
 269               (names (split-string (elt params 3))))
 270          (apply #'lirc-add-channel-users (cons channel names))))
 271
 272       ((and "JOIN"
 273             (guard (equal lirc-nick (lirc-msg-src msg))))
 274        (let ((channel (car (lirc-msg-params msg))))
 275          (setq lirc-current-channel channel)
 276          (lirc-add-channel channel)
 277          (lirc-render-prompt)))
 278
 279       ("JOIN"
 280        (let ((channel (car (lirc-msg-params msg)))
 281              (nick (lirc-msg-src msg)))
 282         (lirc-add-channel-users channel nick)))
 283
 284       ((and "PART"
 285             (guard (equal lirc-nick (lirc-msg-src msg))))
 286        (setq lirc-current-channel nil)
 287        (lirc-del-channel (car (lirc-msg-params msg))))
 288
 289       ("PART"
 290        (let ((channel (car (lirc-msg-params msg)))
 291              (nick (lirc-msg-src msg)))
 292          (lirc-del-channel-users channel nick)))
 293
 294       ((and "NICK"
 295             (guard (equal lirc-nick (lirc-msg-src msg))))
 296        (setq lirc-nick (car (lirc-msg-params msg)))
 297        (lirc-display-string (concat "*** Set nick to " lirc-nick)))
 298
 299       ("PRIVMSG"
 300        (let ((nick (lirc-msg-src msg))
 301              (channel (car (lirc-msg-params msg)))
 302              (text (cadr (lirc-msg-params msg))))
 303          (lirc-display-string (concat channel " <" nick "> " text))))
 304       (_
 305        (lirc-display-string (lirc-msg->string msg))))))
 306
 307
 308 ;;; Command entering
 309 ;;
 310
 311 (defun lirc-enter-string (string)
 312   (if (string-prefix-p "/" string)
 313       (pcase (substring string 1)
 314         ((rx (: (let cmd-str (+ (not space))))
 315             (opt
 316              (: (+ " ")
 317                 (let params-str (+ anything)))))
 318          (lirc-send-msg (lirc-msg nil nil
 319                                   cmd-str
 320                                   (if params-str
 321                                       (split-string params-str)
 322                                     nil)))))
 323     (lirc-send-msg (lirc-msg nil nil "PRIVMSG" lirc-current-channel string))))
 324
 325 (defun lirc-enter ()
 326   "Enter current contents of line after prompt."
 327   (interactive)
 328   (with-current-buffer "*lirc*"
 329     (lirc-enter-string
 330      (buffer-substring lirc-input-marker (point-max)))
 331     (let ((inhibit-read-only t))
 332       (delete-region lirc-input-marker (point-max)))))
 333
 334
 335
 336 ;;; Mode
 337 ;;
 338
 339 (defvar lirc-mode-map
 340   (let ((map (make-sparse-keymap)))
 341     (define-key map (kbd "RET") 'lirc-enter)
 342     map))
 343
 344 (define-derived-mode lirc-mode text-mode "lirc"
 345   "Major mode for LIRC.")
 346
 347 (when (fboundp 'evil-set-initial-state)
 348   (evil-set-initial-state 'lirc-mode 'insert))
 349
 350 ;;; Main start procedure
 351 ;;
 352
 353 (defun lirc ()
 354   "Switch to *lirc* buffer."
 355   (interactive)
 356   (if (get-buffer "*lirc*")
 357       (switch-to-buffer "*lirc*")
 358     (switch-to-buffer "*lirc*"))
 359   (lirc-mode)
 360   (lirc-setup-buffer)
 361   (lirc-connect)
 362   "Started LIRC.")
 363
 364
 365
 366 ;;; lirc.el ends here