Added irclog.

Pascal J. Bourguignon [2021-03-01 03:48]
Added irclog.
Filename
small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd
small-cl-pgms/irclog-prompter/irclog.lisp
small-cl-pgms/irclog-prompter/loader.lisp
small-cl-pgms/irclog-prompter/main.lisp
small-cl-pgms/irclog-prompter/packages.lisp
small-cl-pgms/irclog-prompter/prompter-test.lisp
small-cl-pgms/irclog-prompter/prompter.lisp
small-cl-pgms/irclog-prompter/scratch.lisp
diff --git a/small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd b/small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd
new file mode 100644
index 0000000..6fcad17
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd
@@ -0,0 +1,49 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               com.informatimago.small-cl-pgms.irclog.asd
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Irclog: fetch the irc logs for the last messages.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2020-10-30 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2020 - 2020
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero 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 Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(asdf:defsystem "com.informatimago.small-cl-pgms.irclog"
+  :description "Irclog: fetch the irc logs for the last messages."
+  :author "Pascal J. Bourguignon"
+  :version "1.0.0"
+  :license "AGPL3"
+  :depends-on ("com.informatimago.common-lisp.cesarum"
+               "com.informatimago.common-lisp.interactive"
+               ;; "cl-irc" "cl-json"
+               "drakma" "split-sequence" "cl-ppcre")
+  :components ((:file "irclog")
+               (:file "prompter")
+               (:file "prompter-test" :depends-on ("prompter"))
+               (:file "main" :depends-on ("prompter" "irclog"))))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/irclog-prompter/irclog.lisp b/small-cl-pgms/irclog-prompter/irclog.lisp
new file mode 100644
index 0000000..622423a
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/irclog.lisp
@@ -0,0 +1,77 @@
+(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.IRCLOG"
+  (:use "COMMON-LISP")
+  (:documentation "This package fetches new lines from irclogs.")
+  (:export "GET-NEW-MESSAGES"))
+
+(in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.IRCLOG")
+
+
+(defvar *irclog-base-url* "https://ccl.clozure.com/irc-logs/")
+(defvar *channels* '("lisp") #|'("lisp" "scheme")|#
+  "A list of channels to fetch from the irclog server.")
+(defparameter *ignore-commands* '("joined" "left" "quit"))
+
+(defun log-url (channel)
+  ;; https://ccl.clozure.com/irc-logs/lisp/lisp-2020-10.txt
+  (multiple-value-bind (se mi ho da month year)
+      (decode-universal-time (get-universal-time) 0)
+    (declare (ignore se mi ho da))
+    (format nil "~A~A/~:*~A-~4,'0D-~2,'0D.txt"
+            *irclog-base-url* channel year month)))
+
+(defclass cached-resource ()
+  ((url             :initarg  :url :reader   cached-resource-url)
+   (previous-length :initform 0    :accessor cached-resource-previous-length)
+   (contents        :initform nil  :accessor cached-resource-contents)
+   (headers         :initform '()  :accessor cached-resource-headers)
+   (last-modified   :initform 0    :accessor cached-resource-last-modified)))
+
+(defmethod fetch-resource ((resource cached-resource))
+  (multiple-value-bind (contents status headers uri stream do-close reason)
+      (drakma:http-request (cached-resource-url resource)
+                           :external-format-in :latin-1)
+    (declare (ignore uri))
+    (unwind-protect
+         (if (= status 200)
+             (setf (cached-resource-previous-length resource) (length (cached-resource-contents resource))
+                   (cached-resource-contents resource) contents
+                   (cached-resource-headers  resource) headers)
+             (error "Could not fetch the resource ~S for ~D ~A~%"
+                    (cached-resource-url resource) status reason))
+      (when do-close (close stream)))))
+
+(defvar *cached-resources* nil
+  "maps the channel to the cached resources.")
+
+(defun initialize-cached-resources ()
+  (let ((table (make-hash-table :test (function equal))))
+    (dolist (channel *channels* (setf *cached-resources* table))
+      (fetch-resource
+       (setf (gethash channel table)
+             (make-instance 'cached-resource
+                            :url (log-url channel)))))))
+
+(defun third-word (line)
+  (ignore-errors
+   (let* ((start (1+ (position #\space line :start (1+ (position #\space line)))))
+          (end   (position #\space line :start start)))
+     (subseq line start end))))
+
+(defun get-new-messages ()
+  (unless *cached-resources*
+    (setf *cached-resources* (initialize-cached-resources)))
+  (mapcan (lambda (channel)
+            (let ((resource (gethash channel *cached-resources*)))
+              (fetch-resource resource)
+              (let ((lines (subseq (cached-resource-contents resource) (cached-resource-previous-length resource))))
+                (when (plusp (length lines))
+                  (let ((messages (remove-if
+                                   (lambda (line)
+                                     (or (zerop (length line))
+                                         (member (third-word line) *ignore-commands*
+                                                 :test (function equal))))
+                                   (split-sequence:split-sequence #\newline lines))))
+                    (when messages (list (list channel messages))))))))
+          *channels*))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/irclog-prompter/loader.lisp b/small-cl-pgms/irclog-prompter/loader.lisp
new file mode 100644
index 0000000..2e91cc5
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/loader.lisp
@@ -0,0 +1,4 @@
+
+(pushnew #P"~/src/public/lisp/small-cl-pgms/irclog-prompter/" asdf:*central-registry* :test (function equalp))
+(ql:quickload "com.informatimago.small-cl-pgms.irclog")
+(require :cocoa)
diff --git a/small-cl-pgms/irclog-prompter/main.lisp b/small-cl-pgms/irclog-prompter/main.lisp
new file mode 100644
index 0000000..9632390
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/main.lisp
@@ -0,0 +1,25 @@
+(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.IRCLOG.MAIN"
+  (:use "COMMON-LISP")
+  (:use "COM.INFORMATIMAGO.SMALL-CL-PGMS.IRCLOG"
+        "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER")
+  (:documentation "This package fetches new lines from irclogs,
+and displays them before the next prompt.")
+  (:export "MAIN"))
+
+(in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.IRCLOG.MAIN")
+
+(defun display-new-irc-messages ()
+  (let ((messages  (get-new-messages)))
+    (when messages
+      (fresh-line)
+      (loop :for (channel messages) :in messages
+            :do (loop :for message :in messages
+                      :do (format t "#~A: ~A~%" channel message)))
+      (force-output))))
+
+(defun main ()
+  (install-prompt-functions)
+  (add-prompt-function 'display-new-irc-messages)
+  (values))
+
+(main)
diff --git a/small-cl-pgms/irclog-prompter/packages.lisp b/small-cl-pgms/irclog-prompter/packages.lisp
new file mode 100644
index 0000000..8b13789
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/packages.lisp
@@ -0,0 +1 @@
+
diff --git a/small-cl-pgms/irclog-prompter/prompter-test.lisp b/small-cl-pgms/irclog-prompter/prompter-test.lisp
new file mode 100644
index 0000000..2db20e1
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/prompter-test.lisp
@@ -0,0 +1,16 @@
+(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER.TEST"
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER"))
+(in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER.TEST")
+
+(assert (eq (ADD-PROMPT-FUNCTION 'com.informatimago.common-lisp.interactive.interactive:date)
+            'com.informatimago.common-lisp.interactive.interactive:date))
+(assert (eq (REMOVE-PROMPT-FUNCTION 'com.informatimago.common-lisp.interactive.interactive:date)
+            'com.informatimago.common-lisp.interactive.interactive:date))
+(assert (null (LIST-PROMPT-FUNCTIONS)))
+(assert (eq (ADD-PROMPT-FUNCTION 'com.informatimago.common-lisp.interactive.interactive:date)
+            'com.informatimago.common-lisp.interactive.interactive:date))
+(assert (equal (LIST-PROMPT-FUNCTIONS)
+               '(com.informatimago.common-lisp.interactive.interactive:date)))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/irclog-prompter/prompter.lisp b/small-cl-pgms/irclog-prompter/prompter.lisp
new file mode 100644
index 0000000..fe21b61
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/prompter.lisp
@@ -0,0 +1,92 @@
+(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER"
+  (:use "COMMON-LISP")
+  (:documentation "This package installs functions to be called before the REPL prompt is displayed.")
+  (:export "ADD-PROMPT-FUNCTION"
+           "REMOVE-PROMPT-FUNCTION"
+           "LIST-PROMPT-FUNCTIONS"
+           "PROMPT-FUNCTION-ERRORS"
+           "INSTALL-PROMPT-FUNCTIONS"))
+(in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER")
+
+(defvar *prompt-functions* '()
+  "A list of functions to be run before printing the promtp.")
+
+(defvar *prompt-function-errors* '())
+
+(defun ADD-PROMPT-FUNCTION (function)
+  "Add at the end of the prompt functions list, a new function to be called each time before the prompt is printed."
+  (setf *prompt-functions* (nconc *prompt-functions* (list function)))
+  function)
+
+(defun REMOVE-PROMPT-FUNCTION (function)
+  "Remove an old function from the list of prompt functions."
+  (setf *prompt-functions* (delete function *prompt-functions*))
+  function)
+
+(defun LIST-PROMPT-FUNCTIONS ()
+  "A fresh-list of prompt functions, in the order they're called."
+  (copy-list *prompt-functions*))
+
+(defun run-prompt-functions (stream)
+  "Calls each prompt function in turn, with *STANDARD-OUTPUT* bound to STREAM..
+Errors are handled and printed.
+STREAM is flushed."
+  (let ((*standard-output* stream))
+    (dolist (pfun *prompt-functions*)
+      (handler-case
+          (funcall pfun)
+        (error (err)
+          (force-output *standard-output*)
+          (format *error-output* "Error while running prompt function ~S:~%  ~A~%" pfun err)
+          (force-output *error-output*)
+          (remove-prompt-function pfun)
+          (push (list pfun err) *prompt-function-errors*))))
+    (finish-output))
+  (values))
+
+(defun prompt-function-errors ()
+  (prog1 *prompt-function-errors*
+    (setf *prompt-function-errors* nil)))
+
+(defvar *prompt-functions-installed* nil)
+
+(defun install-prompt-functions ()
+  "Installs the prompt functions hook into the implamentation."
+  (unless *prompt-functions-installed*
+
+    ;; Note: when using slime/swank, the REPL is implemented by emacs,
+    ;; and the prompt is displayed by emacs.
+    ;; Therefore this feature must be implemented in emacs.
+    #+swank (progn
+              )
+
+    ;; For ccl, we cannot use the *read-loop-function* since once we're
+    ;; inside the loop, this hook is not used anymore (it's used when
+    ;; starting a new REPL).  Therefore we have to patch print-listener-prompt.
+    #+ccl  (let ((ccl::*warn-if-redefine-kernel* nil))
+             (eval
+              '(defun ccl::print-listener-prompt (stream &optional (force t))
+                (unless ccl::*quiet-flag*
+                  (when (or force (not (eq ccl::*break-level* ccl::*last-break-level*)))
+                    (run-prompt-functions stream)
+                    (let ((ccl::*listener-indent* nil))
+                      (fresh-line stream)
+                      (format stream ccl::*listener-prompt-format* ccl::*break-level*))
+                    (setf ccl::*last-break-level* ccl::*break-level*)))
+                (force-output stream))))
+
+    #+sbcl (let ((old-prompt-fun sb-int:*repl-prompt-fun*))
+             (setf sb-int:*repl-prompt-fun*
+                   (lambda (stream)
+                     (if (null stream)
+                         old-prompt-fun
+                         (progn
+                           (run-prompt-functions stream)
+                           (force-output stream)
+                           (funcall old-prompt-fun stream)
+                           (finish-output stream))))))
+
+    #-(or ccl sbcl) (error "Not implemented yet for ~A" (lisp-implementation-type))
+    (setf *prompt-functions-installed* t)))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/irclog-prompter/scratch.lisp b/small-cl-pgms/irclog-prompter/scratch.lisp
new file mode 100644
index 0000000..f813f72
--- /dev/null
+++ b/small-cl-pgms/irclog-prompter/scratch.lisp
@@ -0,0 +1,46 @@
+(install-prompt-functions)
+
+
+(progn
+  (let ((resource (gethash "lisp" *cached-resources*)))
+   (let ((url   (cached-resource-url resource))
+         (start (cached-resource-previous-length resource)))
+     (multiple-value-bind (contents status headers uri stream do-close reason)
+         (drakma:http-request url
+                              :external-format-in :latin-1
+                              :keep-alive t :close nil
+                              :range '(0 0))
+       (declare (ignorable uri))
+       (let ((end (ignore-errors
+                   (let ((content-range (cdr (assoc :content-range headers))))
+                     (parse-integer content-range :start (1+ (position #\/ content-range)))))))
+         (if (and (= 206 status) end)
+             (progn
+               (multiple-value-setq (contents status headers uri stream do-close reason)
+                 (drakma:http-request url
+                                      :external-format-in :latin-1
+                                      :range (list start end)))
+               (unwind-protect
+                    (if (= status 200)
+                        (setf (cached-resource-previous-length resource) end
+                              (cached-resource-headers  resource) headers
+                              (cached-resource-contents resource) contents)
+                        (error "Could not fetch the resource ~S for ~D ~A~%"
+                               (cached-resource-url resource) status reason))
+                 (when do-close (close stream))))
+
+             (error "Could not fetch length of resource ~S for ~D ~A~%"
+                    (cached-resource-url resource) status reason))))))
+
+  (cached-resource-contents (gethash "lisp" *cached-resources*))
+
+(initialize-cached-resources)
+(get-new-messages))
+
+
+(initialize-cached-resources)
+(install-prompt-functions)
+(cached-resource-contents (gethash "lisp" *cached-resources*))
+
+
+(get-new-messages)
ViewGit