From: Tim Vaughan Date: Tue, 29 Jun 2021 15:38:17 +0000 (+0200) Subject: Renamed project. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=b0daf99266a79eebc1dfb40eb2906fa0a295f595;p=lurk.git Renamed project. --- diff --git a/lirc.el b/lirc.el deleted file mode 100644 index ad1a8fa..0000000 --- a/lirc.el +++ /dev/null @@ -1,638 +0,0 @@ -;;; lirc.el --- Lightweight irc client -*- lexical-binding:t -*- - -;; Copyright (C) 2021 Tim Vaughan - -;; Author: Tim Vaughan -;; Created: 14 June 2021 -;; Version: 1.0 -;; Keywords: network -;; Homepage: http://thelambdalab.xyz/erc -;; Package-Requires: ((emacs "26")) - -;; This file is not part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this file. If not, see . - -;;; Commentary: - -;;; Code: - -(provide 'lirc) - - -;;; Customizations -;; - -(defgroup lirc nil - "Lightweight IRC client." - :group 'network) - -(defcustom lirc-nick "plugd" - "Default nick.") -(defcustom lirc-full-name "plugd" - "Default full name.") -(defcustom lirc-user-name "plugd" - "Default user name.") - -(defcustom lirc-networks - '(("libera" "irc.libera.chat" 6697) - ("freenode" "chat.freenode.net" 6697) - ("local" "localhost" 6697)) - "IRC networks.") - -(defcustom lirc-allow-ipv6 nil - "Set to non-nil to allow use of IPv6.") - -;;; Faces -;; - -(defface lirc-text - '((t :inherit font-lock-preprocessor-face)) - "Face used for Lirc text.") - -(defface lirc-your-nick - '((t :inherit font-lock-constant-face)) - "Face used for highlighting your nick.") - -(defface lirc-prompt - '((t :inherit org-level-2)) - "Face used for the prompt.") - -(defface lirc-context - '((t :inherit org-list-dt)) - "Face used for the context name in the prompt.") - -(defface lirc-faded - '((t :inherit font-lock-preprocessor-face)) - "Face used for faded Lirc text.") - -(defface lirc-bold - '((t :inherit font-lock-function-name-face)) - "Face used for bold Lirc text.") - -(defface lirc-error - '((t :inherit font-lock-regexp-grouping-construct)) - "Face used for Lirc error text.") - -;;; Global variables -;; - -(defvar lirc-version "Lirc v0.1") - -(defvar lirc-notice-prefix - (concat - (propertize - "-" 'face 'lirc-faded) - (propertize - "!" 'face 'lirc-bold) - (propertize - "-" 'face 'lirc-faded))) - -(defvar lirc-error-prefix - (propertize "!!!" 'face 'lirc-error)) - - -(defvar lirc-prompt-string - (propertize "> " 'face 'lirc-prompt)) - - -;;; Network process -;; - -(defvar lirc-response "") - -(defun lirc-filter (proc string) - (dolist (line (split-string (concat lirc-response string) "\n")) - (if (string-suffix-p "\r" line) - (lirc-eval-msg-string (string-trim line)) - (setq lirc-response line)))) - -(defun lirc-sentinel (proc string) - (unless (equal "open" (string-trim string)) - (lirc-display-error "Disconnected from server.") - (clrhash lirc-contexts) - (setq lirc-current-context nil) - (lirc-render-prompt) - (cancel-timer lirc-ping-timer))) - -(defun lirc-start-process (network) - (let* ((row (assoc network lirc-networks)) - (host (elt row 1)) - (port (elt row 2)) - (flags (seq-drop row 3))) - (make-network-process :name "lirc" - :host host - :service port - :family (if lirc-allow-ipv6 nil 'ipv4) - :filter #'lirc-filter - :sentinel #'lirc-sentinel - :nowait nil - :tls-parameters (if (memq :notls flags) - nil - (cons 'gnutls-x509pki - (gnutls-boot-parameters - :type 'gnutls-x509pki - :hostname host))) - :buffer "*lirc*"))) - -(defvar lirc-ping-timer nil) -(defvar lirc-ping-period 60) - -(defun lirc-ping-function () - (lirc-send-msg (lirc-msg nil nil "PING" (car (process-contact (get-process "lirc"))))) - (setq lirc-ping-timer (run-with-timer lirc-ping-period nil #'lirc-ping-function))) - -(defun lirc-connect (network) - (if (get-process "lirc") - (lirc-display-error "Already connected. Disconnect first.") - (if (not (assoc network lirc-networks)) - (lirc-display-error "Network '" network "' is unknown.") - (clrhash lirc-contexts) - (setq lirc-current-context nil) - (lirc-start-process network) - (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name)) - (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick)) - (setq lirc-ping-timer (run-with-timer lirc-ping-period nil #'lirc-ping-function))))) - - -(defun lirc-send-msg (msg) - (let ((proc (get-process "lirc"))) - (if (and proc (eq (process-status proc) 'open)) - (process-send-string proc (concat (lirc-msg->string msg) "\r\n")) - (lirc-display-error "No server connection established.") - (error "No server connection established")))) - - -;;; Server messages -;; - -(defun lirc--as-string (obj) - (if obj - (with-output-to-string (princ obj)) - nil)) - -(defun lirc-msg (tags src cmd &rest params) - (list (lirc--as-string tags) - (lirc--as-string src) - (upcase (lirc--as-string cmd)) - (mapcar #'lirc--as-string - (if (and params (listp (elt params 0))) - (elt params 0) - params)))) - -(defun lirc-msg-tags (msg) (elt msg 0)) -(defun lirc-msg-src (msg) (elt msg 1)) -(defun lirc-msg-cmd (msg) (elt msg 2)) -(defun lirc-msg-params (msg) (elt msg 3)) -(defun lirc-msg-trail (msg) - (let ((params (lirc-msg-params msg))) - (if params - (elt params (- (length params) 1))))) - -(defvar lirc-msg-regex - (rx - (opt (: "@" (group (* (not (or "\n" "\r" ";" " "))))) - (* whitespace)) - (opt (: ":" (: (group (* (not (any space "!" "@")))) - (* (not (any space))))) - (* whitespace)) - (group (: (* (not whitespace)))) - (* whitespace) - (opt (group (+ not-newline)))) - "Regex used to parse IRC messages. -Note that this regex is incomplete. Noteably, we discard the non-nick -portion of the source component of the message, as LIRC doesn't use this.") - -(defun lirc-string->msg (string) - (if (string-match lirc-msg-regex string) - (let* ((tags (match-string 1 string)) - (src (match-string 2 string)) - (cmd (upcase (match-string 3 string))) - (params-str (match-string 4 string)) - (params - (if params-str - (let* ((idx (cl-search ":" params-str)) - (l (split-string (string-trim (substring params-str 0 idx)))) - (r (if idx (list (substring params-str (+ 1 idx))) nil))) - (append l r)) - nil))) - (apply #'lirc-msg (append (list tags src cmd) params))) - (error "Failed to parse string " string))) - -(defun lirc--filtered-join (&rest args) - (string-join (seq-filter (lambda (el) el) args) " ")) - -(defun lirc-msg->string (msg) - (let ((tags (lirc-msg-tags msg)) - (src (lirc-msg-src msg)) - (cmd (lirc-msg-cmd msg)) - (params (lirc-msg-params msg))) - (lirc--filtered-join - (if tags (concat "@" tags) nil) - (if src (concat ":" src) nil) - cmd - (if (> (length params) 1) - (string-join (seq-take params (- (length params) 1)) " ") - nil) - (if (> (length params) 0) - (concat ":" (elt params (- (length params) 1))) - nil)))) - - -;;; Contexts and users -;; - -(defvar lirc-context-table - '((channel lirc-display-channel-message) - (nick lirc-display-private-message) - (host lirc-diaplay-server-message))) - -(defvar lirc-current-context nil) -(defvar lirc-contexts (make-hash-table :test #'equal)) - -(defun lirc-add-context (name) - (puthash name nil lirc-contexts)) - -(defun lirc-del-context (name) - (remhash name lirc-contexts)) - -(defun lirc-get-context-users (name) - (gethash name lirc-contexts)) - -(defun lirc-add-context-users (context users) - (puthash context - (append users - (gethash context lirc-contexts)) - lirc-contexts)) - -(defun lirc-del-context-user (context user) - (puthash context - (remove user (gethash context lirc-contexts)) - lirc-contexts)) - -(defun lirc-del-user (user) - (dolist (context (lirc-get-context-list)) - (lirc-del-context-user context user))) - -(defun lirc-get-context-type (name) - (cond - ((string-prefix-p "#" name) 'channel) - ((string-match-p (rx (or "." "localhost")) name) 'host) - (t 'nick))) - -(defun lirc-get-context-list () - (let ((res nil)) - (maphash (lambda (key val) - (cl-pushnew key res)) - lirc-contexts) - res)) - -(defun lirc-get-next-context (&optional prev) - (if lirc-current-context - (let* ((context-list (if prev - (reverse (lirc-get-context-list)) - (lirc-get-context-list))) - (context-list* (member lirc-current-context context-list))) - (if (> (length context-list*) 1) - (cadr context-list*) - (car context-list))) - nil)) - -(defun lirc-cycle-contexts (&optional rev) - (if lirc-current-context - (progn - (setq lirc-current-context (lirc-get-next-context rev)) - (lirc-render-prompt)) - (lirc-display-error "No channels joined."))) - -(defun lirc-cycle-contexts-forward () - (interactive) - (lirc-cycle-contexts)) - -(defun lirc-cycle-contexts-reverse () - (interactive) - (lirc-cycle-contexts t)) - -;;; Buffer -;; - -(defun lirc-display-string (&rest strings) - (with-current-buffer (get-buffer-create "*lirc*") - (save-excursion - (goto-char lirc-prompt-marker) - (let ((inhibit-read-only t) - (old-pos (marker-position lirc-prompt-marker)) - (adaptive-fill-regexp (rx (= 6 anychar)))) - (insert-before-markers - (propertize (concat (format-time-string "%H:%M") " ") - 'face 'lirc-text - 'read-only t) - (propertize (concat (apply #'concat strings) "\n") - 'read-only t)) - (fill-region old-pos lirc-prompt-marker))))) - -(defun lirc-render-prompt () - (with-current-buffer "*lirc*" - (let ((update-point (= lirc-input-marker (point))) - (update-window-points (mapcar (lambda (w) - (list (= (window-point w) lirc-input-marker) - w)) - (get-buffer-window-list nil nil t)))) - (save-excursion - (set-marker-insertion-type lirc-prompt-marker nil) - (set-marker-insertion-type lirc-input-marker t) - (let ((inhibit-read-only t)) - (delete-region lirc-prompt-marker lirc-input-marker) - (goto-char lirc-prompt-marker) - (insert - (propertize (if lirc-current-context - lirc-current-context - "") - 'face 'lirc-context - 'read-only t) - (propertize lirc-prompt-string - 'face 'lirc-prompt - 'read-only t - 'rear-nonsticky t))) - (set-marker-insertion-type lirc-input-marker nil)) - (if update-point - (goto-char lirc-input-marker)) - (dolist (v update-window-points) - (if (car v) - (set-window-point (cadr v) lirc-input-marker)))))) - -(defvar lirc-prompt-marker nil - "Marker for prompt position in LIRC buffer.") - -(defvar lirc-input-marker nil - "Marker for prompt position in LIRC buffer.") - -(defun lirc-setup-buffer () - (with-current-buffer (get-buffer-create "*lirc*") - (if (markerp lirc-prompt-marker) - (set-marker lirc-prompt-marker (point-max)) - (setq lirc-prompt-marker (point-max-marker))) - (if (markerp lirc-input-marker) - (set-marker lirc-input-marker (point-max)) - (setq lirc-input-marker (point-max-marker))) - (goto-char (point-max)) - (lirc-render-prompt))) - - -;;; Output formatting -;; - -(defun lirc-display-message (from to text) - (let* ((to-type (lirc-get-context-type to)) - (display-fun (cadr (assoc to-type lirc-context-table)))) - (funcall display-fun from to text))) - -(defun lirc-display-channel-message (from to text) - (lirc-display-string - (propertize (concat to - " <" from "> " - text) - 'face 'lirc-text))) - - -(defun lirc-display-action (channel-name nick action) - (lirc-display-string (concat channel-name - " * " - (propertize (concat nick " " action) - 'face 'lirc-text)))) - -(defun lirc-display-private-message (from to text) - (lirc-display-string - (concat - (propertize - (concat "[" from " -> " to "] " - text) - 'face 'lirc-text)))) - - -(defun lirc-display-notice (&rest notices) - (lirc-display-string lirc-notice-prefix " " (apply #'concat notices))) - -(defun lirc-display-error (&rest messages) - (lirc-display-string lirc-error-prefix " " - (propertize (apply #'concat messages) - 'face 'lirc-error))) - -;;; Message evaluation -;; - -(defun lirc-eval-msg-string (string) - ;; (lirc-display-string string) - (let* ((msg (lirc-string->msg string))) - (pcase (lirc-msg-cmd msg) - ("PING" - (lirc-send-msg - (lirc-msg nil nil "PONG" (lirc-msg-params msg))) - (lirc-display-notice "ping-pong")) - - ("353" ; NAMEREPLY - (let* ((params (lirc-msg-params msg)) - (channel (elt params 2)) - (names (split-string (elt params 3)))) - (lirc-add-context-users channel names))) - - ("366" ; ENDOFNAMES - (lirc-display-notice - (lirc--as-string (length (lirc-get-context-users lirc-current-context))) - " users in " lirc-current-context)) - - ((rx (= 3 (any digit))) - (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " "))) - - ((and "JOIN" - (guard (equal lirc-nick (lirc-msg-src msg)))) - (let ((channel-name (car (lirc-msg-params msg)))) - (lirc-add-context channel-name) - (setq lirc-current-context channel-name) - (lirc-display-notice "Joining channel " channel-name) - (lirc-render-prompt))) - - ("JOIN" - (let ((channel-name (car (lirc-msg-params msg))) - (nick (lirc-msg-src msg))) - (lirc-add-context-users channel-name (list nick)) - (lirc-display-notice nick " joined channel " channel-name))) - - ((and "PART" - (guard (equal lirc-nick (lirc-msg-src msg)))) - (let ((channel-name (car (lirc-msg-params msg)))) - (lirc-display-notice "Left channel " channel-name) - (lirc-del-context channel-name) - (if (equal channel-name lirc-current-context) - (setq lirc-current-context (lirc-get-next-context))) - (lirc-render-prompt))) - - ("PART" - (let ((channel-name (car (lirc-msg-params msg))) - (nick (lirc-msg-src msg))) - (lirc-del-context-user channel-name nick) - (lirc-display-notice nick " left channel " channel-name))) - - ("QUIT" - (let ((nick (lirc-msg-src msg)) - (reason (mapconcat 'identity (lirc-msg-params msg) " "))) - (lirc-del-user nick) - (lirc-display-notice nick " quit: " reason))) - - ((and "NICK" - (guard (equal lirc-nick (lirc-msg-src msg)))) - (setq lirc-nick (car (lirc-msg-params msg))) - (lirc-display-notice "Set nick to " lirc-nick)) - - ("NICK" - (let ((old-nick (lirc-msg-src msg)) - (new-nick (car (lirc-msg-params msg)))) - (lirc-display-notice nick " is now known as " new-nick) - (lirc-rename-user nick new-nick))) - - ("NOTICE" - (let ((nick (lirc-msg-src msg)) - (channel (car (lirc-msg-params msg))) - (text (cadr (lirc-msg-params msg)))) - (pcase text - ((rx (: "\01VERSION " - (let version (* (not "\01"))) - "\01")) - (lirc-display-notice "CTCP version reply from " nick ": " version)) - (_ - (lirc-display-notice text))))) - - ("PRIVMSG" - (let* ((from (lirc-msg-src msg)) - (params (lirc-msg-params msg)) - (to (car params)) - (text (cadr params))) - (pcase text - ("\01VERSION\01" - (let ((version-string (concat lirc-version " - running on GNU Emacs " emacs-version))) - (lirc-send-msg (lirc-msg nil nil "NOTICE" - (list from (concat "\01VERSION " - version-string - "\01"))))) - (lirc-display-notice "CTCP version request received from " from)) - - ((rx (let ping (: "\01PING " (* (not "\01")) "\01"))) - (lirc-send-msg (lirc-msg nil nil "NOTICE" (list from ping))) - (lirc-display-notice "CTCP ping received from " from)) - - ("\01USERINFO\01" - (lirc-display-notice "CTCP userinfo request from " from " (no response sent)")) - - (_ - (lirc-display-message from to text))))) - (_ - (lirc-display-string (lirc-msg->string msg)))))) - - -;;; Command entering -;; - -(defun lirc-enter-string (string) - (if (string-prefix-p "/" string) - (pcase (substring string 1) - ((rx (: "CONNECT " (let network (* not-newline)))) - (lirc-display-notice "Attempting to connect to " network "...") - (lirc-connect network)) - - ((rx (: "TOPIC " (let new-topic (* not-newline)))) - (lirc-send-msg (lirc-msg nil nil "TOPIC" lirc-current-context new-topic))) - - ((rx (: "ME " (let action (* not-newline)))) - (lirc-send-msg (lirc-msg nil nil "PRIVMSG" - (list lirc-current-context - (concat "\01ACTION " action "\01")))) - (lirc-display-action lirc-nick action)) - - ((rx (: "VERSION" " " (let nick (* (not whitespace))))) - (lirc-send-msg (lirc-msg nil nil "PRIVMSG" - (list nick "\01VERSION\01"))) - (lirc-display-notice "CTCP version request sent to " nick)) - - ((rx "PART" (opt (: " " (let channel (* not-newline))))) - (if (or lirc-current-context channel) - (lirc-send-msg (lirc-msg nil nil "PART" (if channel - channel - lirc-current-context))) - (lirc-display-error "No current channel to leave."))) - - ((rx "MSG " - (let to (* (not whitespace))) - " " - (let text (* not-newline))) - (lirc-send-msg (lirc-msg nil nil "PRIVMSG" to text)) - (lirc-display-message lirc-nick to text)) - - ((rx (: (let cmd-str (+ (not whitespace))) - (opt (: " " (let params-str (* not-newline)))))) - (lirc-send-msg (lirc-msg nil nil (upcase cmd-str) - (if params-str - (split-string params-str) - nil))))) - - (unless (string-empty-p string) - (if lirc-current-context - (progn - (lirc-send-msg (lirc-msg nil nil "PRIVMSG" - lirc-current-context - string)) - (lirc-display-message lirc-nick lirc-current-context string)) - (lirc-display-error "No current context."))))) - -(defun lirc-enter () - "Enter current contents of line after prompt." - (interactive) - (with-current-buffer "*lirc*" - (lirc-enter-string - (buffer-substring lirc-input-marker (point-max))) - (let ((inhibit-read-only t)) - (delete-region lirc-input-marker (point-max))))) - - -;;; Mode -;; - -(defvar lirc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'lirc-enter) - (define-key map (kbd "") 'lirc-cycle-contexts-forward) - (define-key map (kbd "") 'lirc-cycle-contexts-reverse) - map)) - -(define-derived-mode lirc-mode text-mode "lirc" - "Major mode for LIRC.") - -(when (fboundp 'evil-set-initial-state) - (evil-set-initial-state 'lirc-mode 'insert)) - -;;; Main start procedure -;; - -(defun lirc () - "Switch to *lirc* buffer." - (interactive) - (if (get-buffer "*lirc*") - (switch-to-buffer "*lirc*") - (switch-to-buffer "*lirc*")) - (lirc-mode) - (lirc-setup-buffer) - "Started LIRC.") - - - -;;; lirc.el ends here diff --git a/lurk.el b/lurk.el new file mode 100644 index 0000000..06df515 --- /dev/null +++ b/lurk.el @@ -0,0 +1,638 @@ +;;; lurk.el --- Little Unified iRc Klient -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Tim Vaughan + +;; Author: Tim Vaughan +;; Created: 14 June 2021 +;; Version: 1.0 +;; Keywords: network +;; Homepage: http://thelambdalab.xyz/erc +;; Package-Requires: ((emacs "26")) + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;;; Code: + +(provide 'lurk) + + +;;; Customizations +;; + +(defgroup lurk nil + "Little Unified iRc Klient." + :group 'network) + +(defcustom lurk-nick "plugd" + "Default nick.") +(defcustom lurk-full-name "plugd" + "Default full name.") +(defcustom lurk-user-name "plugd" + "Default user name.") + +(defcustom lurk-networks + '(("libera" "irc.libera.chat" 6697) + ("freenode" "chat.freenode.net" 6697) + ("local" "localhost" 6697)) + "IRC networks.") + +(defcustom lurk-allow-ipv6 nil + "Set to non-nil to allow use of IPv6.") + +;;; Faces +;; + +(defface lurk-text + '((t :inherit font-lock-preprocessor-face)) + "Face used for Lurk text.") + +(defface lurk-your-nick + '((t :inherit font-lock-constant-face)) + "Face used for highlighting your nick.") + +(defface lurk-prompt + '((t :inherit org-level-2)) + "Face used for the prompt.") + +(defface lurk-context + '((t :inherit org-list-dt)) + "Face used for the context name in the prompt.") + +(defface lurk-faded + '((t :inherit font-lock-preprocessor-face)) + "Face used for faded Lurk text.") + +(defface lurk-bold + '((t :inherit font-lock-function-name-face)) + "Face used for bold Lurk text.") + +(defface lurk-error + '((t :inherit font-lock-regexp-grouping-construct)) + "Face used for Lurk error text.") + +;;; Global variables +;; + +(defvar lurk-version "Lurk v0.1") + +(defvar lurk-notice-prefix + (concat + (propertize + "-" 'face 'lurk-faded) + (propertize + "!" 'face 'lurk-bold) + (propertize + "-" 'face 'lurk-faded))) + +(defvar lurk-error-prefix + (propertize "!!!" 'face 'lurk-error)) + + +(defvar lurk-prompt-string + (propertize "> " 'face 'lurk-prompt)) + + +;;; Network process +;; + +(defvar lurk-response "") + +(defun lurk-filter (proc string) + (dolist (line (split-string (concat lurk-response string) "\n")) + (if (string-suffix-p "\r" line) + (lurk-eval-msg-string (string-trim line)) + (setq lurk-response line)))) + +(defun lurk-sentinel (proc string) + (unless (equal "open" (string-trim string)) + (lurk-display-error "Disconnected from server.") + (clrhash lurk-contexts) + (setq lurk-current-context nil) + (lurk-render-prompt) + (cancel-timer lurk-ping-timer))) + +(defun lurk-start-process (network) + (let* ((row (assoc network lurk-networks)) + (host (elt row 1)) + (port (elt row 2)) + (flags (seq-drop row 3))) + (make-network-process :name "lurk" + :host host + :service port + :family (if lurk-allow-ipv6 nil 'ipv4) + :filter #'lurk-filter + :sentinel #'lurk-sentinel + :nowait nil + :tls-parameters (if (memq :notls flags) + nil + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :type 'gnutls-x509pki + :hostname host))) + :buffer "*lurk*"))) + +(defvar lurk-ping-timer nil) +(defvar lurk-ping-period 60) + +(defun lurk-ping-function () + (lurk-send-msg (lurk-msg nil nil "PING" (car (process-contact (get-process "lurk"))))) + (setq lurk-ping-timer (run-with-timer lurk-ping-period nil #'lurk-ping-function))) + +(defun lurk-connect (network) + (if (get-process "lurk") + (lurk-display-error "Already connected. Disconnect first.") + (if (not (assoc network lurk-networks)) + (lurk-display-error "Network '" network "' is unknown.") + (clrhash lurk-contexts) + (setq lurk-current-context nil) + (lurk-start-process network) + (lurk-send-msg (lurk-msg nil nil "USER" lurk-user-name 0 "*" lurk-full-name)) + (lurk-send-msg (lurk-msg nil nil "NICK" lurk-nick)) + (setq lurk-ping-timer (run-with-timer lurk-ping-period nil #'lurk-ping-function))))) + + +(defun lurk-send-msg (msg) + (let ((proc (get-process "lurk"))) + (if (and proc (eq (process-status proc) 'open)) + (process-send-string proc (concat (lurk-msg->string msg) "\r\n")) + (lurk-display-error "No server connection established.") + (error "No server connection established")))) + + +;;; Server messages +;; + +(defun lurk--as-string (obj) + (if obj + (with-output-to-string (princ obj)) + nil)) + +(defun lurk-msg (tags src cmd &rest params) + (list (lurk--as-string tags) + (lurk--as-string src) + (upcase (lurk--as-string cmd)) + (mapcar #'lurk--as-string + (if (and params (listp (elt params 0))) + (elt params 0) + params)))) + +(defun lurk-msg-tags (msg) (elt msg 0)) +(defun lurk-msg-src (msg) (elt msg 1)) +(defun lurk-msg-cmd (msg) (elt msg 2)) +(defun lurk-msg-params (msg) (elt msg 3)) +(defun lurk-msg-trail (msg) + (let ((params (lurk-msg-params msg))) + (if params + (elt params (- (length params) 1))))) + +(defvar lurk-msg-regex + (rx + (opt (: "@" (group (* (not (or "\n" "\r" ";" " "))))) + (* whitespace)) + (opt (: ":" (: (group (* (not (any space "!" "@")))) + (* (not (any space))))) + (* whitespace)) + (group (: (* (not whitespace)))) + (* whitespace) + (opt (group (+ not-newline)))) + "Regex used to parse IRC messages. +Note that this regex is incomplete. Noteably, we discard the non-nick +portion of the source component of the message, as LURK doesn't use this.") + +(defun lurk-string->msg (string) + (if (string-match lurk-msg-regex string) + (let* ((tags (match-string 1 string)) + (src (match-string 2 string)) + (cmd (upcase (match-string 3 string))) + (params-str (match-string 4 string)) + (params + (if params-str + (let* ((idx (cl-search ":" params-str)) + (l (split-string (string-trim (substring params-str 0 idx)))) + (r (if idx (list (substring params-str (+ 1 idx))) nil))) + (append l r)) + nil))) + (apply #'lurk-msg (append (list tags src cmd) params))) + (error "Failed to parse string " string))) + +(defun lurk--filtered-join (&rest args) + (string-join (seq-filter (lambda (el) el) args) " ")) + +(defun lurk-msg->string (msg) + (let ((tags (lurk-msg-tags msg)) + (src (lurk-msg-src msg)) + (cmd (lurk-msg-cmd msg)) + (params (lurk-msg-params msg))) + (lurk--filtered-join + (if tags (concat "@" tags) nil) + (if src (concat ":" src) nil) + cmd + (if (> (length params) 1) + (string-join (seq-take params (- (length params) 1)) " ") + nil) + (if (> (length params) 0) + (concat ":" (elt params (- (length params) 1))) + nil)))) + + +;;; Contexts and users +;; + +(defvar lurk-context-table + '((channel lurk-display-channel-message) + (nick lurk-display-private-message) + (host lurk-diaplay-server-message))) + +(defvar lurk-current-context nil) +(defvar lurk-contexts (make-hash-table :test #'equal)) + +(defun lurk-add-context (name) + (puthash name nil lurk-contexts)) + +(defun lurk-del-context (name) + (remhash name lurk-contexts)) + +(defun lurk-get-context-users (name) + (gethash name lurk-contexts)) + +(defun lurk-add-context-users (context users) + (puthash context + (append users + (gethash context lurk-contexts)) + lurk-contexts)) + +(defun lurk-del-context-user (context user) + (puthash context + (remove user (gethash context lurk-contexts)) + lurk-contexts)) + +(defun lurk-del-user (user) + (dolist (context (lurk-get-context-list)) + (lurk-del-context-user context user))) + +(defun lurk-get-context-type (name) + (cond + ((string-prefix-p "#" name) 'channel) + ((string-match-p (rx (or "." "localhost")) name) 'host) + (t 'nick))) + +(defun lurk-get-context-list () + (let ((res nil)) + (maphash (lambda (key val) + (cl-pushnew key res)) + lurk-contexts) + res)) + +(defun lurk-get-next-context (&optional prev) + (if lurk-current-context + (let* ((context-list (if prev + (reverse (lurk-get-context-list)) + (lurk-get-context-list))) + (context-list* (member lurk-current-context context-list))) + (if (> (length context-list*) 1) + (cadr context-list*) + (car context-list))) + nil)) + +(defun lurk-cycle-contexts (&optional rev) + (if lurk-current-context + (progn + (setq lurk-current-context (lurk-get-next-context rev)) + (lurk-render-prompt)) + (lurk-display-error "No channels joined."))) + +(defun lurk-cycle-contexts-forward () + (interactive) + (lurk-cycle-contexts)) + +(defun lurk-cycle-contexts-reverse () + (interactive) + (lurk-cycle-contexts t)) + +;;; Buffer +;; + +(defun lurk-display-string (&rest strings) + (with-current-buffer (get-buffer-create "*lurk*") + (save-excursion + (goto-char lurk-prompt-marker) + (let ((inhibit-read-only t) + (old-pos (marker-position lurk-prompt-marker)) + (adaptive-fill-regexp (rx (= 6 anychar)))) + (insert-before-markers + (propertize (concat (format-time-string "%H:%M") " ") + 'face 'lurk-text + 'read-only t) + (propertize (concat (apply #'concat strings) "\n") + 'read-only t)) + (fill-region old-pos lurk-prompt-marker))))) + +(defun lurk-render-prompt () + (with-current-buffer "*lurk*" + (let ((update-point (= lurk-input-marker (point))) + (update-window-points (mapcar (lambda (w) + (list (= (window-point w) lurk-input-marker) + w)) + (get-buffer-window-list nil nil t)))) + (save-excursion + (set-marker-insertion-type lurk-prompt-marker nil) + (set-marker-insertion-type lurk-input-marker t) + (let ((inhibit-read-only t)) + (delete-region lurk-prompt-marker lurk-input-marker) + (goto-char lurk-prompt-marker) + (insert + (propertize (if lurk-current-context + lurk-current-context + "") + 'face 'lurk-context + 'read-only t) + (propertize lurk-prompt-string + 'face 'lurk-prompt + 'read-only t + 'rear-nonsticky t))) + (set-marker-insertion-type lurk-input-marker nil)) + (if update-point + (goto-char lurk-input-marker)) + (dolist (v update-window-points) + (if (car v) + (set-window-point (cadr v) lurk-input-marker)))))) + +(defvar lurk-prompt-marker nil + "Marker for prompt position in LURK buffer.") + +(defvar lurk-input-marker nil + "Marker for prompt position in LURK buffer.") + +(defun lurk-setup-buffer () + (with-current-buffer (get-buffer-create "*lurk*") + (if (markerp lurk-prompt-marker) + (set-marker lurk-prompt-marker (point-max)) + (setq lurk-prompt-marker (point-max-marker))) + (if (markerp lurk-input-marker) + (set-marker lurk-input-marker (point-max)) + (setq lurk-input-marker (point-max-marker))) + (goto-char (point-max)) + (lurk-render-prompt))) + + +;;; Output formatting +;; + +(defun lurk-display-message (from to text) + (let* ((to-type (lurk-get-context-type to)) + (display-fun (cadr (assoc to-type lurk-context-table)))) + (funcall display-fun from to text))) + +(defun lurk-display-channel-message (from to text) + (lurk-display-string + (propertize (concat to + " <" from "> " + text) + 'face 'lurk-text))) + + +(defun lurk-display-action (channel-name nick action) + (lurk-display-string (concat channel-name + " * " + (propertize (concat nick " " action) + 'face 'lurk-text)))) + +(defun lurk-display-private-message (from to text) + (lurk-display-string + (concat + (propertize + (concat "[" from " -> " to "] " + text) + 'face 'lurk-text)))) + + +(defun lurk-display-notice (&rest notices) + (lurk-display-string lurk-notice-prefix " " (apply #'concat notices))) + +(defun lurk-display-error (&rest messages) + (lurk-display-string lurk-error-prefix " " + (propertize (apply #'concat messages) + 'face 'lurk-error))) + +;;; Message evaluation +;; + +(defun lurk-eval-msg-string (string) + ;; (lurk-display-string string) + (let* ((msg (lurk-string->msg string))) + (pcase (lurk-msg-cmd msg) + ("PING" + (lurk-send-msg + (lurk-msg nil nil "PONG" (lurk-msg-params msg))) + (lurk-display-notice "ping-pong")) + + ("353" ; NAMEREPLY + (let* ((params (lurk-msg-params msg)) + (channel (elt params 2)) + (names (split-string (elt params 3)))) + (lurk-add-context-users channel names))) + + ("366" ; ENDOFNAMES + (lurk-display-notice + (lurk--as-string (length (lurk-get-context-users lurk-current-context))) + " users in " lurk-current-context)) + + ((rx (= 3 (any digit))) + (lurk-display-notice (mapconcat 'identity (cdr (lurk-msg-params msg)) " "))) + + ((and "JOIN" + (guard (equal lurk-nick (lurk-msg-src msg)))) + (let ((channel-name (car (lurk-msg-params msg)))) + (lurk-add-context channel-name) + (setq lurk-current-context channel-name) + (lurk-display-notice "Joining channel " channel-name) + (lurk-render-prompt))) + + ("JOIN" + (let ((channel-name (car (lurk-msg-params msg))) + (nick (lurk-msg-src msg))) + (lurk-add-context-users channel-name (list nick)) + (lurk-display-notice nick " joined channel " channel-name))) + + ((and "PART" + (guard (equal lurk-nick (lurk-msg-src msg)))) + (let ((channel-name (car (lurk-msg-params msg)))) + (lurk-display-notice "Left channel " channel-name) + (lurk-del-context channel-name) + (if (equal channel-name lurk-current-context) + (setq lurk-current-context (lurk-get-next-context))) + (lurk-render-prompt))) + + ("PART" + (let ((channel-name (car (lurk-msg-params msg))) + (nick (lurk-msg-src msg))) + (lurk-del-context-user channel-name nick) + (lurk-display-notice nick " left channel " channel-name))) + + ("QUIT" + (let ((nick (lurk-msg-src msg)) + (reason (mapconcat 'identity (lurk-msg-params msg) " "))) + (lurk-del-user nick) + (lurk-display-notice nick " quit: " reason))) + + ((and "NICK" + (guard (equal lurk-nick (lurk-msg-src msg)))) + (setq lurk-nick (car (lurk-msg-params msg))) + (lurk-display-notice "Set nick to " lurk-nick)) + + ("NICK" + (let ((old-nick (lurk-msg-src msg)) + (new-nick (car (lurk-msg-params msg)))) + (lurk-display-notice nick " is now known as " new-nick) + (lurk-rename-user nick new-nick))) + + ("NOTICE" + (let ((nick (lurk-msg-src msg)) + (channel (car (lurk-msg-params msg))) + (text (cadr (lurk-msg-params msg)))) + (pcase text + ((rx (: "\01VERSION " + (let version (* (not "\01"))) + "\01")) + (lurk-display-notice "CTCP version reply from " nick ": " version)) + (_ + (lurk-display-notice text))))) + + ("PRIVMSG" + (let* ((from (lurk-msg-src msg)) + (params (lurk-msg-params msg)) + (to (car params)) + (text (cadr params))) + (pcase text + ("\01VERSION\01" + (let ((version-string (concat lurk-version " - running on GNU Emacs " emacs-version))) + (lurk-send-msg (lurk-msg nil nil "NOTICE" + (list from (concat "\01VERSION " + version-string + "\01"))))) + (lurk-display-notice "CTCP version request received from " from)) + + ((rx (let ping (: "\01PING " (* (not "\01")) "\01"))) + (lurk-send-msg (lurk-msg nil nil "NOTICE" (list from ping))) + (lurk-display-notice "CTCP ping received from " from)) + + ("\01USERINFO\01" + (lurk-display-notice "CTCP userinfo request from " from " (no response sent)")) + + (_ + (lurk-display-message from to text))))) + (_ + (lurk-display-string (lurk-msg->string msg)))))) + + +;;; Command entering +;; + +(defun lurk-enter-string (string) + (if (string-prefix-p "/" string) + (pcase (substring string 1) + ((rx (: "CONNECT " (let network (* not-newline)))) + (lurk-display-notice "Attempting to connect to " network "...") + (lurk-connect network)) + + ((rx (: "TOPIC " (let new-topic (* not-newline)))) + (lurk-send-msg (lurk-msg nil nil "TOPIC" lurk-current-context new-topic))) + + ((rx (: "ME " (let action (* not-newline)))) + (lurk-send-msg (lurk-msg nil nil "PRIVMSG" + (list lurk-current-context + (concat "\01ACTION " action "\01")))) + (lurk-display-action lurk-nick action)) + + ((rx (: "VERSION" " " (let nick (* (not whitespace))))) + (lurk-send-msg (lurk-msg nil nil "PRIVMSG" + (list nick "\01VERSION\01"))) + (lurk-display-notice "CTCP version request sent to " nick)) + + ((rx "PART" (opt (: " " (let channel (* not-newline))))) + (if (or lurk-current-context channel) + (lurk-send-msg (lurk-msg nil nil "PART" (if channel + channel + lurk-current-context))) + (lurk-display-error "No current channel to leave."))) + + ((rx "MSG " + (let to (* (not whitespace))) + " " + (let text (* not-newline))) + (lurk-send-msg (lurk-msg nil nil "PRIVMSG" to text)) + (lurk-display-message lurk-nick to text)) + + ((rx (: (let cmd-str (+ (not whitespace))) + (opt (: " " (let params-str (* not-newline)))))) + (lurk-send-msg (lurk-msg nil nil (upcase cmd-str) + (if params-str + (split-string params-str) + nil))))) + + (unless (string-empty-p string) + (if lurk-current-context + (progn + (lurk-send-msg (lurk-msg nil nil "PRIVMSG" + lurk-current-context + string)) + (lurk-display-message lurk-nick lurk-current-context string)) + (lurk-display-error "No current context."))))) + +(defun lurk-enter () + "Enter current contents of line after prompt." + (interactive) + (with-current-buffer "*lurk*" + (lurk-enter-string + (buffer-substring lurk-input-marker (point-max))) + (let ((inhibit-read-only t)) + (delete-region lurk-input-marker (point-max))))) + + +;;; Mode +;; + +(defvar lurk-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'lurk-enter) + (define-key map (kbd "") 'lurk-cycle-contexts-forward) + (define-key map (kbd "") 'lurk-cycle-contexts-reverse) + map)) + +(define-derived-mode lurk-mode text-mode "lurk" + "Major mode for LURK.") + +(when (fboundp 'evil-set-initial-state) + (evil-set-initial-state 'lurk-mode 'insert)) + +;;; Main start procedure +;; + +(defun lurk () + "Switch to *lurk* buffer." + (interactive) + (if (get-buffer "*lurk*") + (switch-to-buffer "*lurk*") + (switch-to-buffer "*lurk*")) + (lurk-mode) + (lurk-setup-buffer) + "Started LURK.") + + + +;;; lurk.el ends here