Added tracker

7 files changed, 202 insertions, 39 deletions

diff --git a/.gitignore b/.gitignore
index 544c6c9..b30cc76 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,5 @@
 .env
 *~
 \#*\#
+*.fasl
 
diff --git a/newsphaser.asd b/newsphaser.asd
index e1bbc48..0482950 100644
--- a/newsphaser.asd
+++ b/newsphaser.asd
@@ -24,8 +24,13 @@
     :description "A Mastodon bot to aggregate posts by popularity."
     :homepage "https://github.com/Etenil/newsphaser"
     :serial T
-    :components ((:file "unhtml")
-		 (:file "phaser"))
+    :components ((:file "package")
+		 (:file "unhtml")
+		 (:file "toots")
+		 (:file "tracker")
+		 (:file "reporter"))
     :depends-on (:tooter
 		 :cl-dotenv
-		 :plump))
+		 :cl-redis
+		 :plump
+		 :alexandria))
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..65a686c
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,41 @@
+(defpackage :phaser.unhtml
+  (:use :common-lisp)
+  (:export
+   #:text-excerpt))
+
+(defpackage :phaser.toots
+  (:use :cl)
+  (:export
+   #:get-timeline
+   #:*client*
+   #:get-status))
+
+(defpackage :phaser.tracker
+  (:use :cl)
+  (:import-from :phaser.toots #:get-timeline)
+  (:import-from :phaser.toots #:get-status)
+  (:export
+   #:track-statuses
+   #:collect-tracking))
+
+(defpackage :phaser.reporter
+  (:use
+   :common-lisp)
+  (:import-from :phaser.unhtml #:text-excerpt)
+  (:import-from :phaser.tracker #:track-statuses)
+  (:import-from :phaser.toots #:*client*)
+  (:export
+   #:reblog-top-statuses))
+
+(defpackage #:phaser
+  (:use
+   #:cl
+   #:phaser.unhtml
+   #:phaser.toots
+   #:phaser.tracker
+   #:phaser.reporter)
+  (:shadowing-import-from #:phaser.reporter #:block))
+
+(dolist (package '(#:phaser.reporter #:phaser.tracker))
+  (do-symbols (symbol package)
+    (export symbol '#:phaser)))
diff --git a/phaser.lisp b/reporter.lisp
index 2fcda54..48ec0fa 100644
--- a/phaser.lisp
+++ b/reporter.lisp
@@ -16,32 +16,10 @@
 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defpackage :phaser
-  (:use
-   :common-lisp)
-  (:import-from :phaser.unhtml #:text-excerpt)
-  (:export
-   #:get-timeline
-   #:load-timeline
-   #:load-top-statuses
-   #:reblog-top-statuses
-   #:summarize-top-statuses))
-
 (in-package :phaser)
 
-(ignore-errors
- ;; Don't signal if .env is missing.
- (.env:load-env (merge-pathnames ".env")))
-
-(defvar *client* (make-instance 'tooter:client
-				:base (uiop:getenv "MASTODON_URL")
-				:name "Newsphaser bot"
-				:key (uiop:getenv "MASTODON_KEY")
-				:secret (uiop:getenv "MASTODON_SECRET")
-				:access-token (uiop:getenv "MASTODON_TOKEN")))
 (defvar *timeline-page-size* 50
   "Maximum number of statuses retrieved from the timeline for each request")
-
 (defvar *timeline-min-age* (* 24 3600)
   "Minimum age of statuses before being considered for ranking")
 (defvar *timeline-max-age* (* 48 3600)	; 48h
@@ -67,11 +45,6 @@
   (or (null page)
       (not (null (outdated-statuses page)))))
 
-(defun flatten (structure)
-  (cond ((null structure) nil)
-        ((atom structure) (list structure))
-        (t (mapcan #'flatten structure))))
-
 (defun load-timeline-pages (min-id &optional (pages '()) (iter-num 0))
   "Load statuses from the timeline up to *TIMELINE-MAX-AGE* or MIN-ID."
   (let* ((max-id (if (null pages)
@@ -85,7 +58,7 @@
 				(list page)
 				(cons page pages))))
     (if (or (last-page-p page) (>= iter-num *max-requests*))
-	(flatten statuses-and-page)
+	(alexandria:flatten statuses-and-page)
 	(load-timeline-pages min-id statuses-and-page (1+ iter-num)))))
 
 (defun load-timeline ()
@@ -101,9 +74,6 @@
 	 (* (tooter:reblogs-count status) *pop-boosts-factor*))
      (- (get-universal-time) (tooter:created-at status))))
 
-(defun get-timeline ()
-  (tooter:timeline *client* :home))
-
 (defun load-top-statuses ()
   (let* ((timeline (load-timeline))
 	 (ranked-statuses (sort (mapcar (lambda (status)
diff --git a/toots.lisp b/toots.lisp
new file mode 100644
index 0000000..f36c9eb
--- /dev/null
+++ b/toots.lisp
@@ -0,0 +1,20 @@
+(in-package :phaser.toots)
+
+(ignore-errors
+ ;; Don't signal if .env is missing.
+ (.env:load-env (merge-pathnames ".env")))
+
+
+(defvar *client*
+  (make-instance 'tooter:client
+		 :base (uiop:getenv "MASTODON_URL")
+		 :name "Newsphaser bot"
+		 :key (uiop:getenv "MASTODON_KEY")
+		 :secret (uiop:getenv "MASTODON_SECRET")
+		 :access-token (uiop:getenv "MASTODON_TOKEN")))
+
+(defun get-timeline (&key (timeline :home))
+  (tooter:timeline *client* timeline))
+
+(defun get-status (id)
+  (tooter:find-status *client* id))
diff --git a/tracker.lisp b/tracker.lisp
new file mode 100644
index 0000000..d1ccd78
--- /dev/null
+++ b/tracker.lisp
@@ -0,0 +1,131 @@
+(in-package :phaser.tracker)
+
+(defvar *max-num* 100)
+(defvar *max-age* (* 14 24 3600)) ; Two weeks
+(defvar *tracking-key-fmt* "HISTORY-~a")
+(defvar *index-key* "STATUSES")
+
+(defun tracking-key-status-id (key)
+  (subseq key (length (format nil *tracking-key-fmt* ""))))
+
+(defun status-data-key (status)
+  (format nil "status-~a" (tooter:id status)))
+
+(defstruct status-tracker
+  time id)
+
+(defun status-tracker-to-cons (tracker)
+  (cons (status-tracker-time tracker)
+	(status-tracker-id tracker)))
+
+(defun status-tracker-from-cons (pair)
+  (make-status-tracker :time (car pair)
+		       :id (cdr pair)))
+
+(defun status-tracker-from-status (status)
+  (make-status-tracker :time (tooter:created-at status)
+		       :id (tooter:id status)))
+
+(defun read-from-redis (key)
+  (let ((data (red:get key)))
+    (when data
+      (read-from-string data))))
+
+(defun read-list-from-redis (key)
+  (let ((data (red:lrange key 0 -1)))
+    (mapcar #'read-from-string data)))
+
+(defun load-status-trackers ()
+  (mapcar #'status-tracker-from-cons
+	  (read-from-redis *index-key*)))
+
+(defun save-status-trakers (trackers)
+  (let ((data (mapcar #'status-tracker-to-cons trackers)))
+    (red:set *index-key* data)
+    trackers))
+
+(defun rand-pick (sequence)
+  "Picks a random number of items from sequence"
+  (subseq sequence 0 (random (length sequence))))
+
+(defun strip-tracked-statuses (tracked-statuses new-statuses)
+  (remove-if
+   (lambda (status)
+     (find (tooter:id status)
+	   tracked-statuses
+	   :test (lambda (id tracker)
+		   (eql id (status-tracker-id tracker)))))
+   new-statuses))
+
+(defun get-new-statuses (tracked-statuses)
+  (let* ((statuses (get-timeline))
+	 (num-statuses-to-pick (- *max-num* (length tracked-statuses)))
+	 (new-statuses (rand-pick
+			(strip-tracked-statuses tracked-statuses statuses))))
+    (if (> (length new-statuses) num-statuses-to-pick)
+	(subseq new-statuses 0 num-statuses-to-pick)
+	new-statuses)))
+
+(defun track-status (tracker)
+  (let ((status (get-status (status-tracker-id tracker))))
+    (red:lpush (format nil *tracking-key-fmt* (tooter:id status))
+		(list
+		 (cons 'time (get-universal-time))
+		 (cons 'favourites (tooter:favourites-count status))
+		 (cons 'replies (tooter:replies-count status))
+		 (cons 'reblogs (tooter:reblogs-count status))))))
+
+(defun track-statuses ()
+  (redis:with-connection ()
+    (let ((tracked-statuses (load-status-trackers)))
+
+      ;; Fill up the tracked status pool
+      (when (< (length tracked-statuses) *max-num*)
+	(setf tracked-statuses (nconc
+				tracked-statuses
+				(mapcar
+				 #'status-tracker-from-status
+				 (get-new-statuses tracked-statuses)))))
+
+      ;; for each status, request details
+      (mapc #'track-status tracked-statuses)
+
+      ;; if status is older than max-age, remove from list of tracked statuses
+      (setf tracked-statuses (remove-if
+			      (lambda (tracker)
+				(< (status-tracker-time tracker)
+				   (- (get-universal-time) *max-age*)))
+			      tracked-statuses))
+
+      ;; Persist tracking list
+      (save-status-trakers tracked-statuses)
+      ))
+  )
+
+(defun collect-status-tracking (id)
+  (read-list-from-redis (format nil *tracking-key-fmt* id)))
+
+(defun collect-tracking ()
+  (redis:with-connection ()
+    (let* ((history-keys (red:keys (format nil *tracking-key-fmt* "*")))
+	   (status-history (mapcar (lambda (history-key)
+				     (let ((id (tracking-key-status-id history-key)))
+				       (cons
+					id
+					(collect-status-tracking id))))
+				   history-keys)))
+      ;; status-history
+      (format nil "~{~a~%~}"
+	      (alexandria:flatten
+	       (mapcar (lambda (item)
+			 (mapcar
+			  (lambda (entry)
+			    (format nil "~a,~a,~a,~a,~a"
+				    (car item)
+				    (cdr (assoc 'time entry))
+				    (cdr (assoc 'favourites entry))
+				    (cdr (assoc 'reblogs entry))
+				    (cdr (assoc 'replies entry))))
+			  (cdr item)))
+		       status-history)))
+      )))
diff --git a/unhtml.lisp b/unhtml.lisp
index 7ecea1b..18bab64 100644
--- a/unhtml.lisp
+++ b/unhtml.lisp
@@ -1,8 +1,3 @@
-(defpackage :phaser.unhtml
-  (:use :common-lisp)
-  (:export
-   #:text-excerpt))
-
 (in-package :phaser.unhtml)
 
 (defun node-has-text (node)