1 files changed, 131 insertions, 0 deletions
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)))
+      )))