Skip to content
Commits on Source (5)
Expand all Hide whitespace changes
Inline Side-by-side
.gitignore
View file @ 7302b882
......@@ -6,3 +6,11 @@ intertube-scraper
*#
*.csv
trains*/*
*.dot
*.png
*.svg
*.tar
*.dat
*.jpeg
.#*
*.txt
govuk.css 0 → 100644
View file @ 7302b882
This diff is collapsed.
trackernet.lisp
View file @ 7302b882
......@@ -5,6 +5,18 @@
(defparameter *trackernet-base-url* "http://cloud.tfl.gov.uk/TrackerNet")
(defun statsd-inc (&rest args)
(ignore-errors
(apply #'statsd:inc args)))
(defun statsd-gauge (&rest args)
(ignore-errors
(apply #'statsd:gauge args)))
(defun statsd-counter (&rest args)
(ignore-errors
(apply #'statsd:counter args)))
(defun read-all-from (file)
(with-open-file (source file
:element-type '(unsigned-byte 8))
......@@ -438,7 +450,12 @@
(cl-ansi-text:make-color-string :green :style :background)
tid
cl-ansi-text:+reset-color-string+
train))
train)
;; make a rescuable thingy
(red:setex (format nil "~A-rescue-~A"
line-code tid)
*train-active-expiry-secs*
track-code))
;; mark this train as active
(red:setex (format nil "~A-active-~A"
line-code tid)
......@@ -465,7 +482,7 @@
cl-ansi-text:+reset-color-string+
lcn-train-id
tid)
(statsd:inc "intertube.leading-car-no-change")))
(statsd-inc "intertube.leading-car-no-change")))
;; reserve the leading car no
(red:setex (format nil "~A-lcn-~A"
line-code leading-car-no)
......@@ -493,7 +510,7 @@
cl-ansi-text:+reset-color-string+
set-code-train-id
tid)
(statsd:inc "intertube.set-code-change")))
(statsd-inc "intertube.set-code-change")))
;; reserve the set number
(red:setex (format nil "~A-set-~A-trip-~A"
line-code set-no trip-no)
......@@ -539,6 +556,15 @@
(when score
(parse-integer score))))
(defun redis-last-cpk (key)
"Gets the CONSPACK-decoded value of the last element of the sorted set with the Redis KEY."
(let ((data (first
(red:zrevrangebyscore key "+inf" "-inf"
:limit (cons "0" "1")
:withscores t))))
(when data
(cpk-unbase64 data))))
(defun redis-cpk-sorted-set-all (key)
"Gets all elements of the sorted set KEY, alongside their scores, CONSPACK-decoding each element."
(let ((data
......@@ -625,6 +651,8 @@
"~&archiver: failed to pigz last archive: code ~A~%"
exit-code))))))
(defparameter *rescue-depth* 3)
(defun archive-trains-tar (keys)
"Archive trains from KEYS, a list of Redis train sorted set keys."
(maybe-pigz-last-archive)
......@@ -651,7 +679,17 @@
(cl-ansi-text:make-color-string :red :style :background)
(second train)
cl-ansi-text:+reset-color-string+
last-data))
last-data)
(multiple-value-bind (rescue depth)
(find-rescuable-train (track-code last-data) (subseq (second train) 0 1) *rescue-depth*)
(when rescue
(format
t
"~&archiver: ~Acould rescue with~A: ~A (depth ~A)~%"
(cl-ansi-text:make-color-string :cyan :style :background)
cl-ansi-text:+reset-color-string+
rescue
depth))))
do (conspack-encode-to-archive tar
(format nil "~A-~A.trn"
(first train)
......@@ -713,7 +751,7 @@
;; a reporting gap
(unless (member last-reported-station *termini*
:test #'string=)
(statsd:inc "intertube.archived-early")
(statsd-inc "intertube.archived-early")
(format *error-output*
"~&archiver: WARNING: train ~A last reported at ~A~%"
(second train)
......@@ -766,16 +804,16 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
:start
(handler-case
(let ((pred (fetch-trackernet-prediction line-code station-code)))
(statsd:inc (format nil "scraper.~A-~A.scraped" line-code station-code))
(statsd:inc "intertube.scraped-total")
(statsd-inc (format nil "scraper.~A-~A.scraped" line-code station-code))
(statsd-inc "intertube.scraped-total")
(let ((num-trains (maybe-redis-trackernet-prediction pred)))
(when num-trains
(statsd:gauge (format nil "scraper.~A-~A.trains" line-code station-code) num-trains)
(statsd:inc (format nil "scraper.~A-~A.new" line-code station-code)))))
(statsd-gauge (format nil "scraper.~A-~A.trains" line-code station-code) num-trains)
(statsd-inc (format nil "scraper.~A-~A.new" line-code station-code)))))
;; (format t "~&scraper(~A-~A): new: ~A (~A trains)~%"
;; line-code station-code pred num-trains))))
(error (e)
(statsd:inc (format nil "scraper.~A-~A.errors" line-code station-code))
(statsd-inc (format nil "scraper.~A-~A.errors" line-code station-code))
(format *error-output* "~&scraper(~A-~A): error: ~A~%"
line-code station-code e)))
(go :sleep)
......@@ -820,7 +858,7 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(redis:with-connection ()
(loop
while (not *trackernet-kill-switch*)
do (statsd:gauge (format nil "line.~A.active-trains" line-code)
do (statsd-gauge (format nil "line.~A.active-trains" line-code)
(length (trains-active-on-line line-code)))
do (sleep 1))))
......@@ -833,7 +871,7 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(handler-case
(progn
(archive-trains-tar trains)
(statsd:counter "intertube.archived" (length trains))
(statsd-counter "intertube.archived" (length trains))
(mapc #'red:del trains))
(error (e)
(format *error-output* "~&archiver: failed: ~A~%" e))))))
......@@ -868,6 +906,8 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(length codes))))
(when (> rpm *rude-requests-per-minute*)
(error "~A requests/min is a bit rude" rpm))
(format t "~&~A nodes in rescue table~%"
(hash-table-size *track-rescue-graph*))
(format t "~&starting ~A scrapers, ~A requests/min...~%"
(length codes) rpm))
(setf *trackernet-kill-switch* nil)
......@@ -1020,22 +1060,28 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Create links between subsequent observed track codes in ARCHIVED-TRAIN's history."
(destructuring-bind (filename archived-universal-ts train-key history)
archived-train
(declare (ignore filename archived-universal-ts train-key))
(loop
with first = (pop history)
for next = (pop history)
while next
do (let ((track-code-1 (track-code (third first)))
(track-code-2 (track-code (third next))))
(unless (gethash (list track-code-1 track-code-2) *track-links-set*)
(setf (gethash (list track-code-1 track-code-2) *track-links-set*) 0))
(incf (gethash (list track-code-1 track-code-2) *track-links-set*)))
(symbol-macrolet
((edge-count (gethash (list track-code-1 track-code-2) *track-links-set*)))
(unless edge-count
(setf edge-count 0))
(incf edge-count)
(when (eql (rem edge-count 100) 0)
(format t "~&* ~A -> ~A referenced ~A times~%"
track-code-1 track-code-2 edge-count))))
do (setf first next))))
(defun calculate-exponential-base (max top)
(expt top
(/ 1 max)))
(defun track-links-third-quartile (&key (cutoff 0))
(defun track-links-quartiles (&key (cutoff 0))
(let ((data (sort (loop
for v being the hash-values of *track-links-set*
unless (< v cutoff)
......@@ -1043,16 +1089,18 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
#'<)))
(values
(elt data
(* 3
(* 1
(floor (length data) 4)))
data)))
(elt data
(* 3
(floor (length data) 4))))))
(defun squish-link-length (in max top &optional (base (calculate-exponential-base max top)))
(cond
((> in max) top)
(t (expt base in))))
(defun write-track-links-graphviz (&optional (out *standard-output*))
(defun write-track-links-graphviz (&key (out *standard-output*) (cutoff 5))
"Write the track links out in graphviz format."
(princ "digraph {" out)
(format out "node [shape=box margin=\"0.1,0.1\"];
......@@ -1068,28 +1116,28 @@ layout = \"neato\";")
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(let* ((q3 (track-links-third-quartile :cutoff 5))
(base (calculate-exponential-base q3 3)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
unless (or (< v 5)
(string= a b))
do (let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2))))
(format out "\"~A\" -> \"~A\" [weight=~A len=~F label=\"~A (~A%)\" color=\"0.0 0.0 ~F\" fontcolor=\"0.0 0.0 ~F\" style=\"~A\"];~%"
a
b
score-perc
(- 3.5 score-2)
v
score-perc
(+ 0.2 (/ (- 100 score-perc) 120))
(/ (- 100 score-perc) 100)
(cond
((> score-perc 80) "bold")
((< score-perc 20) "dotted")
(t "solid"))))))
(multiple-value-bind (q1 q3) (track-links-quartiles :cutoff cutoff)
(let* ((base (calculate-exponential-base q3 3)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
unless (or (< v q1)
(string= a b))
do (let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2))))
(format out "\"~A\" -> \"~A\" [weight=~A len=~F label=\"~A (~A%)\" color=\"0.0 0.0 ~F\" fontcolor=\"0.0 0.0 ~F\" style=\"~A\"];~%"
a
b
score-perc
(- 3.5 score-2)
v
score-perc
(+ 0.2 (/ (- 100 score-perc) 120))
(/ (- 100 score-perc) 100)
(cond
((> score-perc 80) "bold")
((< score-perc 20) "dotted")
(t "solid")))))))
(princ "}" out))
......@@ -1103,7 +1151,7 @@ layout = \"neato\";")
(let ((descs-ht (make-hash-table :test 'equal)))
(loop
for key in (get-all "D-track-desc-*")
for actual = (subseq key 13)
for actual = (subseq key #.(length "D-track-desc-"))
for value = (red:get key)
do (when (and
(> (length value) 0)
......@@ -1134,3 +1182,75 @@ color=lightblue;
(string= a b))
do (format out "\"~A\" -> \"~A\" [weight=~A label=\"~A\"];~%" a b v v))
(princ "}" out))
(defun populate-track-links (train-list)
(reset-track-links-set)
(loop
for train in train-list
do (format t "~&*** Processing train ~A...~%" train)
do (unarchive-trains-tar train #'populate-track-links-set))
(format t "~&*** Done; ~A links~%" (hash-table-size *track-links-set*)))
(defun write-track-links-graphviz-to-file (outfile)
(with-open-file (out outfile
:direction :output)
(write-track-links-graphviz :out out)))
(defparameter *track-rescue-graph*
(or
(ignore-errors
(alexandria:alist-hash-table (uiop:read-file-form "./rescue-table.dat")
:test 'equal))
(make-hash-table :test 'equal)))
(defun make-rescue-graph ()
(setf *track-rescue-graph* (make-hash-table :test 'equal))
(multiple-value-bind (q1 q3) (track-links-quartiles :cutoff 5)
(let* ((base (calculate-exponential-base q3 3)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
do (symbol-macrolet ((rescue-val (gethash a *track-rescue-graph*)))
(let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2))))
(when (and
(not (string= b a))
(> v q1)
(>= score-perc 20))
(unless rescue-val
(setf rescue-val nil))
(pushnew b rescue-val))))))))
(defun get-rescuable-trains (line-code)
(mapcar
(lambda (x)
(cons
(format nil "~A-train-~A" line-code (subseq x #.(length "D-rescue-")))
(red:get x)))
(get-all (format nil "~A-rescue-*" line-code))))
(defun %find-rescuable-train (start rescuable bfs-depth)
(when (>= (decf bfs-depth) 0)
(loop
for neighbor in (gethash start *track-rescue-graph*)
with pos
when (setf pos (position neighbor rescuable :key #'cdr :test #'string=))
do (throw 'found (values bfs-depth pos))
unless (string= neighbor start)
do (%find-rescuable-train neighbor rescuable bfs-depth))))
(defun find-rescuable-train (start line-code max-depth)
(let ((rescuable (get-rescuable-trains line-code))
(real-x nil))
(multiple-value-bind (depth pos)
(catch 'found
(loop
;; this is a curse against computer science
;; I'm implementing BFS with DFS because I wrote DFS
;; and then I realised I made a mistake
;; so
for x from 1 upto max-depth
do (setf real-x x)
do (%find-rescuable-train start rescuable x)))
(when depth
(values (elt rescuable pos) real-x)))))
wobsite.lisp 0 → 100644
View file @ 7302b882
(defpackage :intertube-web
(:use :cl))
(in-package :intertube-web)
(setf (cl-who:html-mode) :html5)
(defparameter *title* "intertube")
(defvar *accent-colour* "#1d70b8")
(defun with-rendering-context (func)
(who:with-html-output-to-string (*standard-output* nil
:prologue t)
(:html
:lang "en"
(:head
(:meta
:charset "utf-8")
(:title
(who:esc *title*))
(:meta
:name "viewport"
:content "width=device-width, initial-scale=1, viewport-fit=cover")
(:link
:href "/styles.css"
:rel "stylesheet"))
(:body
:class "govuk-template__body"
(:a
:href "#main-content"
:class "govuk-skip-link"
"Skip to main content")
(:header
:class "govuk-header"
:role "banner"
(:div
:class "govuk-header__container govuk-width-container"
:style (format nil "border-bottom: 10px solid ~A;"
*accent-colour*)
(:div
:class "govuk-header__logo"
(:a
:href "/"
:class "govuk-header__link govuk-header__link--homepage"
(:span
:class "govuk-header__logotype-text"
"intertube")))))
(:div
:class "govuk-width-container"
(:main
:class "govuk-main-wrapper"
:id "main-content"
:role "main"
(who:str (funcall func))))
(:footer
:class "govuk-footer"
:role "contentinfo"
(:div
:class "govuk-width-container"
(:div
:class "govuk-footer__meta"
(:div
:class "govuk-footer__meta-item govuk-footer__meta-item--grow"
(:span
:class "govuk-footer__licence-description"
"This webpage may contain wiggly donkers.")))))))))
(defmacro render (() &body body)
`(with-rendering-context
(lambda ()
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
,@body))))
(hunchentoot:define-easy-handler (css :uri "/styles.css") ()
(hunchentoot:handle-static-file "./govuk.css"))
(defun html-rgb-colour (r g b)
(format nil "#~2,'0x~2,'0x~2,'0x" r g b))
(defparameter *tube-line-data*
'(("Bakerloo" "B" (178 99 0))
("Central" "C" (220 36 31))
("Circle" "H" (255 211 41))
("District" "D" (0 125 50))
("Hammersmith & City" "H" (244 169 190))
("Jubilee" "J" (161 165 167))
("Metropolitan" "M" (155 0 88))
("Northern" "N" (0 0 0))
("Piccadilly" "P" (0 25 168))
("Victoria" "V" (0 152 216))
("Waterloo & City" "W" (147 206 186)))
"A list of Tube line data, in the format (NAME TRACKERNET-CODE RGB-COLOUR)")
(defun tube-line-by-code (code)
(find-if (lambda (d) (string= (second d) code))
*tube-line-data*))
(defparameter *govuk-go-arrow-svg*
"<svg class=\"govuk-button__start-icon\" xmlns=\"http://www.w3.org/2000/svg\" width=\"17.5\" height=\"19\" viewBox=\"0 0 33 40\" aria-hidden=\"true\" focusable=\"false\">)
<path fill=\"currentColor\" d=\"M0 0h13l20 20-20 20H0l20-20z\" />
</svg>")
(defun train-objects-on-line (code)
(let ((active (trackernet::trains-active-on-line code)))
(mapcan (lambda (active-key)
(let* ((train-id (subseq active-key #.(length "X-active-")))
(whole-key (format nil "~A-train-~A" code train-id))
(data (trackernet::redis-last-cpk whole-key)))
(when data
(list data))))
active)))
(defun group-trains-by-destination (train-list)
(let ((dests (make-hash-table :test 'equal)))
(loop
for (observer train-obj) in train-list
do (let ((dest (or (trackernet::destination-desc train-obj)
"???")))
(unless (gethash dest dests)
(setf (gethash dest dests) nil))
(push (list observer train-obj) (gethash dest dests))))
(sort
(alexandria:hash-table-alist dests)
(lambda (a b)
(string< (car a) (car b))))))
(defun string-base64 (str)
(qbase64:encode-bytes
(flexi-streams:string-to-octets
str)))
(defun display-trackernet-train (train)
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
(:tr
:class "train-desc govuk-table__row"
(:td ; Train ID
:class "govuk-table__cell id-field no-phones"
(who:esc (trackernet::train-id train)))
(:td ; Set/trip number
:class "govuk-table__cell"
(let* ((trip-no (trackernet::trip-no train))
(set-no (trackernet::set-no train))
(class (if (string= trip-no "0")
"govuk-tag govuk-tag--green"
"govuk-tag govuk-tag--pink")))
(unless (string= set-no "000")
(who:htm
(:strong
:class class
(who:esc set-no)
(unless (string= trip-no "0")
(who:str " ×")
(who:esc trip-no)))))))
(:td ; LCID
:class "govuk-table__cell id-field no-phones"
(unless (string= (trackernet::lcid train) "0")
(who:esc (trackernet::lcid train))))
(:td ; Destination
:class "govuk-table__cell govuk-!-width-two-thirds"
(:span
(who:esc (or
(trackernet::location-desc train)
"<somewhere>"))
(who:str " ")
(:strong
:class "govuk-tag govuk-tag--grey train-track-code"
(who:esc (trackernet::track-code train))))))))
(hunchentoot:define-easy-handler (line :uri "/line") (code)
(let ((line-data (tube-line-by-code code)))
(unless line-data
(setf (hunchentoot:return-code*) 404)
(hunchentoot:abort-request-handler "not found lol"))
(let* ((*accent-colour* (apply #'html-rgb-colour (third line-data)))
(active-trains (train-objects-on-line code))
(grouped (group-trains-by-destination active-trains)))
(render ()
(:a
:class "govuk-back-link"
:href "/"
"All Tube lines")
(:span
:class "govuk-caption-xl"
"Line overview")
(:h1
:class "govuk-heading-xl"
(who:fmt "~A line"
(first line-data)))
(:p
:class "govuk-body-l"
(:strong
(who:str (length active-trains)))
" trains on the line as of "
(:span
:class "id-field"
(who:esc
(local-time:format-timestring
nil
(local-time:now)
:format
'((:year 4) #\- (:month 2) #\- (:day 2) #\Space
(:hour 2) #\: (:min 2) #\: (:sec 2)))))
".")
(:p
:class "govuk-body"
"Jump to: "
(loop
with len = (length grouped)
for (group . trains) in grouped
for i from 1
do (who:htm
(:a
:class "govuk-link"
:href (format nil "#~A"
(string-base64 group))
(who:esc group)))
unless (eql len i)
do (who:str " &middot; ")))
(:details
:class "govuk-details"
(:summary
:class "govuk-details__summary"
(:span
:class "govuk-details__summary-text"
"What do the columns mean?"))
(:div
:class "govuk-details__text"
(:ul
(:li
(:p
:class "govuk-body"
(:strong "TrainID")
(who:esc
" is a unique identifier given in the open data feeds. It's not entirely clear what, if anything, it correlates to in real life.")))
(:li
(:p
:class "govuk-body"
(:strong "LCID")
(who:esc
" (Leading Car ID) ostensibly identifies the leading car of the train in some way. We use this as our primary means of tracking trains.")))
(:li
(:p
:class "govuk-body"
(:strong "Track codes")
" "
(:strong
:class "govuk-tag govuk-tag--grey"
"ABCDEF")
(who:esc
" are arbitrary pieces of text describing a piece of track on the line. ")))
(:li
(:p
:class "govuk-body"
(:strong "WTT")
(who:esc
" gives the Train Number as found in the TfL ")
(:a
:href "https://tfl.gov.uk/corporate/publications-and-reports/working-timetables"
"Working Timetables (WTT)")
(who:esc
". These are keyed in by train operators at the start of their journey, and can be moved around by Line Controllers if necessary.")
(:ul
(:li
(:p
:class "govuk-body"
(:strong
:class "govuk-tag govuk-tag--pink"
"NNN ×R")
(who:esc
" denotes a train with WTT number NNN, on its Rth trip of the day.")))
(:li
(:p
:class "govuk-body"
(:strong
:class "govuk-tag govuk-tag--green"
"NNN")
(who:esc
" denotes a train with WTT number NNN, on its first run of the day (or where no trip number info is available).")))))))))
(loop
for (group . trains) in grouped
do (who:htm
(:h2
:class "govuk-heading-l"
:id (string-base64 group)
(who:esc group))
(:table
:class "tube-line-list govuk-table"
(:thead
:class "govuk-table__head"
(:tr
:class "govuk-table__row"
(:th
:class "govuk-table__header no-phones"
(:abbr
:title "TrackerNet unique identifier"
"TrainID"))
(:th
:class "govuk-table__header"
(:abbr
:title "Working Timetable train number"
"WTT"))
(:th
:class "govuk-table__header no-phones"
(:abbr
:title "Leading Car ID (LCID)"
"LCID"))
(:th
:class "govuk-table__header govuk-!-width-two-thirds"
"Current location")))
(:tbody
:class "govuk-table__body"
(loop
for (reporter train) in (sort trains #'string<
:key (lambda (trn)
(trackernet::train-id (second trn))))
do (who:str (display-trackernet-train train)))))))))))
(hunchentoot:define-easy-handler (root :uri "/") ()
(render ()
(:h1
:class "govuk-heading-xl"
"Explore the London Underground")
(:p
:class "govuk-body-l"
"Get real-time, second-by-second updates on the movements of Tube trains. ")
(:table
:class "tube-line-list govuk-table"
(:thead
:class "govuk-table__head"
(:tr
:class "govuk-table__row"
(:th
:class "govuk-table__header"
"Line")
(:th
:class "govuk-table__header"
"Data status")
(:th
:class "govuk-table__header"
"Go")))
(:tbody
:class "govuk-table__body"
(loop
for (name code rgb) in *tube-line-data*
do (let ((ntrains (length (trackernet::trains-active-on-line code))))
(who:htm
(:tr
:class "tube-line govuk-table__row"
(:td
:class "tube-line-name govuk-table__cell"
(who:esc name))
(if (> ntrains 0)
(who:htm
(:td
:class "tube-line-status govuk-table__cell"
(:strong
:class "govuk-tag govuk-tag--turquoise"
(who:fmt "~A trains" ntrains))))
(who:htm
(:td
:class "tube-line-status govuk-table__cell"
(:strong
:class "govuk-tag govuk-tag--grey"
"Inactive"))))
(:td
:class "govuk-table__cell"
(:a
:class "govuk-button govuk-button__start tube-line-button"
:style (format nil "background: ~A;"
(apply #'html-rgb-colour rgb))
:role "button"
:draggable "false"
:href (format nil "/line?code=~A" code)
(who:str *govuk-go-arrow-svg*)))))))))))
(push (hunchentoot:create-folder-dispatcher-and-handler "/fonts/" "./fonts/")
hunchentoot:*dispatch-table*)
(defun start-webserver ()
(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 5000)))