X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=lurk.el;h=9ef2fbb95e320eb098d7a2308997d43501c9a8ce;hb=a6382bdca03066f521dc351a9534e40804bcf6de;hp=48b061125d16a7245dcc528c893f97b9f8e03687;hpb=a65cb434a57b716eceb9f85dd5eda20a60dc3d7a;p=lurk.git

diff --git a/lurk.el b/lurk.el
index 48b0611..9ef2fbb 100644
--- a/lurk.el
+++ b/lurk.el
@@ -1,4 +1,4 @@
-;;; lurk.el --- Little Uni-buffer iRc Klient -*- lexical-binding:t -*-
+;;; lurk.el --- Little Unibuffer iRc Klient -*- lexical-binding:t -*-
 
 ;; Copyright (C) 2021 Tim Vaughan
 
@@ -35,7 +35,7 @@
 ;;
 
 (defgroup lurk nil
-  "Little Unified iRc Klient."
+  "Little Unibuffer iRc Klient."
   :group 'network)
 
 (defcustom lurk-nick "plugd"
@@ -58,6 +58,9 @@
 (defcustom lurk-show-joins nil
   "Set to non-nil to be notified of joins, parts and quits.")
 
+(defcustom lurk-display-header t
+  "If non-nil, use buffer header to display information on current host and channel.")
+
 ;;; Faces
 ;;
 
@@ -77,21 +80,44 @@
   '((t :inherit org-agenda-dimmed-todo-face))
   "Face used for faded Lurk text.")
 
+(defface lurk-timestamp
+  '((t :inherit org-agenda-dimmed-todo-face))
+  "Face used for timestamps.")
+
 (defface lurk-error
   '((t :inherit font-lock-regexp-grouping-construct))
   "Face used for Lurk error text.")
 
+(defface lurk-notice
+  '((t :inherit org-upcoming-deadline))
+  "Face used for Lurk notice text.")
+
 ;;; Global variables
 ;;
 
-(defvar lurk-version "Lurk v0.1")
+(defvar lurk-version "Lurk v0.1"
+  "Value of this string is used in response to CTCP version queries.")
 
 (defvar lurk-notice-prefix "-!-")
 
 (defvar lurk-error-prefix "!!!")
 
-(defvar lurk-prompt-string
-  (propertize "> " 'face 'lurk-prompt))
+(defvar lurk-prompt-string ">")
+
+(defvar lurk-debug nil
+  "If non-nil, enable debug mode.")
+
+
+;;; Utility procedures
+;;
+
+(defun lurk--filtered-join (&rest args)
+  (string-join (seq-filter (lambda (el) el) args) " "))
+
+(defun lurk--as-string (obj)
+  (if obj
+      (with-output-to-string (princ obj))
+    nil))
 
 
 ;;; Network process
@@ -157,6 +183,8 @@
     (and proc (eq (process-status proc) 'open))))
 
 (defun lurk-send-msg (msg)
+  (if lurk-debug
+      (lurk-display-string nil nil (lurk-msg->string 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"))
@@ -167,11 +195,6 @@
 ;;; 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)
@@ -220,9 +243,6 @@ portion of the source component of the message, as LURK doesn't use this.")
         (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))
@@ -301,7 +321,9 @@ portion of the source component of the message, as LURK doesn't use this.")
 
 (defun lurk-set-current-context (context)
   (setq lurk-current-context context)
-  (lurk-highlight-context context))
+  (lurk-highlight-context context)
+  (if lurk-zoomed
+      (lurk-zoom-in lurk-current-context)))
 
 (defun lurk-cycle-contexts (&optional rev)
   (if lurk-current-context
@@ -333,7 +355,7 @@ portion of the source component of the message, as LURK doesn't use this.")
                          "")
                        'face 'lurk-context
                        'read-only t)
-           (propertize lurk-prompt-string
+           (propertize (concat lurk-prompt-string " ")
                        'face 'lurk-prompt
                        'read-only t
                        'rear-nonsticky t)))
@@ -350,9 +372,31 @@ portion of the source component of the message, as LURK doesn't use this.")
 (defvar lurk-input-marker nil
   "Marker for prompt position in LURK buffer.")
 
+(defun lurk-setup-header ()
+  (with-current-buffer "*lurk*"
+    (setq-local header-line-format
+                '((:eval
+                   (let ((proc (get-process "lurk")))
+                     (if proc
+                         (concat
+                          "Host: " (car (process-contact proc))
+                          ", Context: "
+                          (if lurk-current-context
+                              (concat
+                               lurk-current-context
+                               " ("
+                               (number-to-string
+                                (length (lurk-get-context-users lurk-current-context)))
+                               " users)")
+                            "Server"))
+                       "No connection")))
+                  (:eval
+                   (if lurk-zoomed " [ZOOMED]" ""))))))
+
 (defun lurk-setup-buffer ()
   (with-current-buffer (get-buffer-create "*lurk*")
     (setq-local scroll-conservatively 1)
+    (setq-local buffer-invisibility-spec nil)
     (if (markerp lurk-prompt-marker)
         (set-marker lurk-prompt-marker (point-max))
       (setq lurk-prompt-marker (point-max-marker)))
@@ -360,24 +404,26 @@ portion of the source component of the message, as LURK doesn't use this.")
         (set-marker lurk-input-marker (point-max))
       (setq lurk-input-marker (point-max-marker)))
     (goto-char (point-max))
-    (lurk-render-prompt)))
+    (lurk-render-prompt)
+    (if lurk-display-header
+        (lurk-setup-header))))
 
 
 ;;; Output formatting and highlighting
 ;;
 
-;; Partially-implemented idea: the face text property can be
-;; a list of faces, applied in order.  By assigning each context
-;; a unique list and keeping track of these in a hash table, we can
-;; easily switch the face corresponding to a particular context
-;; by modifying the elements of this list.
+;; Idea: the face text property can be a list of faces, applied in
+;; order.  By assigning each context a unique list and keeping track
+;; of these in a hash table, we can easily switch the face
+;; corresponding to a particular context by modifying the elements of
+;; this list.
 ;;
 ;; More subtly, we make only the cdrs of this list shared among
 ;; all text of a given context, allowing the cars to be different
 ;; and for different elements of the context-specific text to have
 ;; different styling.
 
-;; Additionally, we can allow selective hiding of contexts via
+;; Additionally, we allow selective hiding of contexts via
 ;; the buffer-invisibility-spec.
 
 (defvar lurk-context-facelists (make-hash-table :test 'equal)
@@ -390,29 +436,44 @@ portion of the source component of the message, as LURK doesn't use this.")
       (puthash context facelist lurk-context-facelists))
     facelist))
 
-(defun lurk-display-string (context &rest strings)
+(defun lurk--fill-strings (col indent &rest strings)
+  (with-temp-buffer
+    (setq buffer-invisibility-spec nil)
+    (let ((fill-column col)
+          (adaptive-fill-regexp (rx-to-string `(= ,indent anychar))))
+      (apply #'insert strings)
+      (fill-region (point-min) (point-max) nil t)
+      (buffer-string))))
+
+(defun lurk-display-string (context prefix &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)))
-            (fill-column 80)
-            (context-atom (if context (intern context) nil)))
+      (let* ((inhibit-read-only t)
+             (old-pos (marker-position lurk-prompt-marker))
+             (padded-timestamp (concat (format-time-string "%H:%M ")))
+             (padded-prefix (if prefix (concat prefix " ") ""))
+             (context-atom (if context (intern context) nil)))
         (insert-before-markers
-         (propertize (concat (format-time-string "%H:%M") " ")
-                     'face (lurk-get-context-facelist context)
-                     'read-only t
-                     'context context
-                     'invisible context-atom
-                     'help-echo (concat "Context: " (or context "none")))
-         (propertize (concat (apply #'concat strings) "\n")
-                     'face (lurk-get-context-facelist context)
-                     'read-only t
-                     'context context
-                     'invisible context-atom
-                     'help-echo (concat "Context: " (or context "none"))))
-        (fill-region old-pos lurk-prompt-marker nil t)))))
+         (lurk--fill-strings
+          80
+          (+ (length padded-timestamp)
+             (length padded-prefix))
+          (propertize padded-timestamp
+                      'face 'lurk-timestamp
+                      'read-only t
+                      'context context
+                      'invisible context-atom)
+          (propertize padded-prefix
+                      'read-only t
+                      'context context
+                      'invisible context-atom)
+          (lurk-add-formatting
+           (propertize (concat (apply #'lurk-buttonify-urls strings) "\n")
+                       'face (lurk-get-context-facelist context)
+                       'read-only t
+                       'context context
+                       'invisible context-atom))))))))
 
 (defun lurk-display-message (from to text)
   (let ((context (if (eq 'channel (lurk-get-context-type to))
@@ -420,11 +481,13 @@ portion of the source component of the message, as LURK doesn't use this.")
                    (if (equal to lurk-nick) from to))))
     (lurk-display-string
      context
-     (pcase (lurk-get-context-type to)
-       ('channel (concat to " <" from "> "))
-       ('nick (concat "[" from " -> " to "] "))
-       (_
-        (error "Unsupported context type")))
+     (propertize
+      (pcase (lurk-get-context-type to)
+        ('channel (concat to " <" from ">"))
+        ('nick (concat "[" from " -> " to "]"))
+        (_
+         (error "Unsupported context type")))
+      'face (lurk-get-context-facelist context))
      text)))
 
 (defun lurk-display-action (from to action-text)
@@ -433,19 +496,21 @@ portion of the source component of the message, as LURK doesn't use this.")
                    (if (equal to lurk-nick) from to))))
     (lurk-display-string
      context
-     "* " from " " action-text)))
-     
+     (propertize
+      (concat context " * " from)
+      'face (lurk-get-context-facelist context))
+     action-text)))
 
 (defun lurk-display-notice (context &rest notices)
   (lurk-display-string
    context
-   lurk-notice-prefix " "
+   (propertize lurk-notice-prefix 'face 'lurk-notice)
    (apply #'concat notices)))
 
 (defun lurk-display-error (&rest messages)
   (lurk-display-string
    nil
-   lurk-error-prefix " "
+   (propertize lurk-error-prefix 'face 'lurk-error)
    (apply #'concat messages)))
 
 (defun lurk-highlight-context (context)
@@ -478,20 +543,80 @@ portion of the source component of the message, as LURK doesn't use this.")
      lurk-context-facelists)
     (force-window-update "*lurk*")))
 
+(defconst lurk-url-regex
+  (rx (:
+       (group (+ alpha))
+       "://"
+       (group (or (+ (any alnum "." "-"))
+                  (+ (any alnum ":"))))
+       (opt (group (: ":" (+ digit))))
+       (opt (group (: "/"
+                      (opt
+                       (* (any alnum "-/.,#:%=&_?~@"))
+                       (any alnum "-/#:%=&_~@")))))))
+  "Imperfect regex used to find URLs in plain text.")
+
+(defun lurk-click-url (button)
+  (browse-url (button-get button 'url)))
+
+(defun lurk-buttonify-urls (&rest strings)
+  "Turn substrings which look like urls in STRING into clickable buttons."
+  (with-temp-buffer
+    (apply #'insert strings)
+    (goto-char (point-min))
+    (while (re-search-forward lurk-url-regex nil t)
+      (let ((url (match-string 0)))
+        (make-text-button (match-beginning 0)
+                          (match-end 0)
+                          'action #'lurk-click-url
+                          'url url
+                          'follow-link t
+                          'face 'button
+                          'help-echo "Open URL in browser.")))
+    (buffer-string)))
+
+(defun lurk-add-formatting (string)
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (let ((bold nil)
+          (italics nil)
+          (underline nil)
+          (strikethrough nil)
+          (prev-point (point)))
+      (while (re-search-forward (rx (any "\x02\x1D\x1F\x1E")) nil t)
+        (let ((beg (+ (match-beginning 0) 1)))
+          (if bold
+              (add-face-text-property prev-point beg '(:weight bold)))
+          (if italics
+              (add-face-text-property prev-point beg '(:slant italic)))
+          (if underline
+              (add-face-text-property prev-point beg '(:underline t)))
+          (if strikethrough
+              (add-face-text-property prev-point beg '(:strike-through t)))
+          (pcase (match-string 0)
+            ("\x02" (setq bold (not bold)))
+            ("\x1D" (setq italics (not italics)))
+            ("\x1F" (setq underline (not underline)))
+            ("\x1E" (setq strikethrough (not strikethrough))))
+          (delete-region (match-beginning 0) (match-end 0))
+          (setq prev-point (point)))))
+    (buffer-string)))
+
+
 ;;; Message evaluation
 ;;
 
 (defun lurk-eval-msg-string (string)
-  ;; (lurk-display-string nil string)
+  (if lurk-debug
+      (lurk-display-string nil nil 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 nil "ping-pong (server initiated)"))
 
       ("PONG")
-       ;; (lurk-display-notice nil "ping-pong (client initiated)"))
 
       ("001"
        (let* ((params (lurk-msg-params msg))
@@ -527,6 +652,8 @@ portion of the source component of the message, as LURK doesn't use this.")
               (topic (elt params 2)))
          (lurk-display-notice channel "Topic: " topic)))
 
+      ("333") ; Avoid displaying these
+
       ((rx (= 3 (any digit)))
        (lurk-display-notice nil (mapconcat 'identity (cdr (lurk-msg-params msg)) " ")))
 
@@ -561,6 +688,21 @@ portion of the source component of the message, as LURK doesn't use this.")
          (if lurk-show-joins
              (lurk-display-notice channel nick " left channel " channel))))
 
+      ((and "KICK")
+       (let ((kicker-nick (lurk-msg-src msg))
+             (channel (car (lurk-msg-params msg)))
+             (nick (cadr (lurk-msg-params msg)))
+             (reason (caddr (lurk-msg-params msg))))
+         (if (equal nick lurk-nick)
+             (progn
+               (lurk-display-notice channel kicker-nick " kicked you from " channel ": " reason)
+               (lurk-del-context channel)
+               (if (equal channel lurk-current-context)
+                   (lurk-set-current-context (lurk-get-next-context)))
+               (lurk-render-prompt))
+           (lurk-del-context-user channel nick)
+           (lurk-display-notice channel kicker-nick " kicked " nick " from " channel ": " reason))))
+
       ("QUIT"
        (let ((nick (lurk-msg-src msg))
              (reason (mapconcat 'identity (lurk-msg-params msg) " ")))
@@ -616,10 +758,6 @@ portion of the source component of the message, as LURK doesn't use this.")
             (lurk-display-action from to action-text))
 
            (_
-            (if (and (equal from "BitBot")
-                     (equal to "##moshpit")
-                     (cl-search "\\_o< QUACK!" text))
-              (lurk-send-msg (lurk-msg nil nil "PRIVMSG" to ",bef")))
             (lurk-display-message from to text)))))
       (_
        (lurk-display-notice nil (lurk-msg->string msg))))))
@@ -631,6 +769,18 @@ portion of the source component of the message, as LURK doesn't use this.")
 (defun lurk-enter-string (string)
   (if (string-prefix-p "/" string)
       (pcase (substring string 1)
+        ((rx "DEBUG")
+         (setq lurk-debug (not lurk-debug))
+         (lurk-display-notice nil "Debug mode now " (if lurk-debug "on" "off") "."))
+
+        ((rx "HEADER")
+         (if header-line-format
+           (progn
+             (setq-local header-line-format nil)
+             (lurk-display-notice nil "Header disabled."))
+           (lurk-setup-header)
+           (lurk-display-notice nil "Header enabled.")))
+
         ((rx (: "CONNECT " (let network (* not-newline))))
          (lurk-display-notice nil "Attempting to connect to " network "...")
          (lurk-connect network))
@@ -669,6 +819,12 @@ portion of the source component of the message, as LURK doesn't use this.")
            (setq lurk-nick nick)
            (lurk-display-notice nil "Set default nick to '" nick "'")))
 
+        ((rx (: "LIST" (* whitespace) string-end))
+         (lurk-display-notice nil "This command can generate lots of output. Use `LIST -yes' if you're sure."))
+
+        ((rx (: "LIST" (+ whitespace) "-YES" (* whitespace) string-end))
+         (lurk-send-msg (lurk-msg nil nil "LIST")))
+
         ((rx "MSG "
              (let to (* (not whitespace)))
              " "
@@ -692,18 +848,42 @@ portion of the source component of the message, as LURK doesn't use this.")
             (lurk-display-message lurk-nick lurk-current-context string))
         (lurk-display-error "No current context.")))))
 
+(defvar lurk-history nil
+  "Commands and messages sent in current session.")
+
+
 (defun lurk-enter ()
   "Enter current contents of line after prompt."
   (interactive)
   (with-current-buffer "*lurk*"
     (let ((line (buffer-substring lurk-input-marker (point-max))))
+      (push line lurk-history)
+      (setq lurk-history-index nil)
       (let ((inhibit-read-only t))
         (delete-region lurk-input-marker (point-max)))
       (lurk-enter-string line))))
 
+(defvar lurk-history-index nil)
+
+(defun lurk-history-cycle (delta)
+  (when lurk-history
+    (with-current-buffer "*lurk*"
+      (if lurk-history-index
+          (setq lurk-history-index
+                (max 0
+                     (min (- (length lurk-history) 1)
+                          (+ delta lurk-history-index))))
+        (setq lurk-history-index 0))
+      (delete-region lurk-input-marker (point-max))
+      (insert (elt lurk-history lurk-history-index)))))
+
+(defun lurk-history-next ()
+  (interactive)
+  (lurk-history-cycle -1))
 
-;;; Command completion
-;;
+(defun lurk-history-prev ()
+  (interactive)
+  (lurk-history-cycle +1))
 
 ;;; Interactive functions
 ;;
@@ -726,18 +906,38 @@ portion of the source component of the message, as LURK doesn't use this.")
     (lurk-zoom-in lurk-current-context))
   (setq lurk-zoomed (not lurk-zoomed)))
 
+(defun lurk-complete-nick ()
+  (interactive)
+  (when (and (>= (point) lurk-input-marker) lurk-current-context)
+    (let* ((end (max lurk-input-marker (point)))
+           (space-idx (save-excursion
+                        (re-search-backward " " lurk-input-marker t)))
+           (start (if space-idx (+ 1 space-idx) lurk-input-marker))
+           (completion-ignore-case t))
+      (unless (string-prefix-p "/" (buffer-substring start end))
+        (completion-in-region start end (lurk-get-context-users lurk-current-context))))))
+
+
 ;;; Mode
 ;;
 
 (defvar lurk-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "RET") 'lurk-enter)
-    (define-key map (kbd "<tab>") 'lurk-complete)
+    (define-key map (kbd "<tab>") 'lurk-complete-nick)
     (define-key map (kbd "C-c C-z") 'lurk-toggle-zoom)
     (define-key map (kbd "<C-tab>") 'lurk-cycle-contexts-forward)
     (define-key map (kbd "<C-S-tab>") 'lurk-cycle-contexts-reverse)
+    (define-key map (kbd "<C-up>") 'lurk-history-prev)
+    (define-key map (kbd "<C-down>") 'lurk-history-next)
+    ;; (when (fboundp 'evil-define-key*)
+    ;;   (evil-define-key* 'insert map
+    ;;                     (kbd "<C-Up>") 'lurk-history-prev
+    ;;                     (kbd "<C-Down>") 'lurk-history-next))
     map))
 
+(defvar lurk-mode-map)
+
 (define-derived-mode lurk-mode text-mode "lurk"
   "Major mode for LURK.")
 
@@ -752,9 +952,9 @@ portion of the source component of the message, as LURK doesn't use this.")
   (interactive)
   (if (get-buffer "*lurk*")
       (switch-to-buffer "*lurk*")
-    (switch-to-buffer "*lurk*"))
-  (lurk-mode)
-  (lurk-setup-buffer)
+    (switch-to-buffer "*lurk*")
+    (lurk-mode)
+    (lurk-setup-buffer))
   "Started LURK.")