Browse Source

redesign, no tidmap, indexing, mgets, rescue improvements

master
eta 2 months ago
parent
commit
6ae9493f22
  1. 2
      deploy.txt
  2. 85
      govuk.css
  3. 462
      trackernet.lisp
  4. 270
      wobsite.lisp

2
deploy.txt

@ -1,7 +1,7 @@
(ql:quickload '(drakma cl-conspack cxml cl-statsd cl-redis qbase64 archive cl-ansi-text gzip-stream bobbin cl-heap local-time log4cl) :silent t)
(load "trackernet.lisp")
(require :sb-sprof)
(format t "** Loaded ~A track links **~%" (hash-table-size trackernet::*normalized-track-links*))
(format t "=> Loaded track links:~% ~A~%" (alexandria:hash-table-alist trackernet::*per-line-track-graph*))
(sb-ext:save-lisp-and-die "./intertube-scraper" :toplevel #'trackernet::main :executable t)

85
govuk.css

@ -38,3 +38,88 @@
.miniviz {
max-width: 100%;
}
.train-history-last {
margin-bottom: 20px !important;
}
.train-history-last .history-station {
background-color: #d53880;
color: white;
}
.train-history-last .history-content-mid {
margin-left: 0;
}
.history-dwell-tardy {
background-color: #d4351c;
font-weight: bold;
color: white;
padding: 0.4rem;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
}
.history-station {
vertical-align: top;
margin-bottom: 0px !important;
padding: 0.4rem;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
display: inline-block;
font-size: 1.5rem;
line-height: 1.25;
font-weight: 700;
}
.history-entry-time {
width: 4rem;
font-size: 1.5rem;
color: #505a5f;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
padding-right: 0.4rem;
line-height: 1.25;
display: inline-block;
margin-right: 0.5rem;
}
.history-entry-time small {
vertical-align: top;
font-size: 1.1rem;
}
.history-station-platform {
display: inline-block;
float: right;
}
.history-transit {
color: darkgray;
font-style: italic;
}
.history-content-mid {
font-style: italic;
color: darkgray;
margin-left: 4rem;
display: inline-block;
padding-top: 0.4rem;
padding-bottom: 0.4rem;
}
.history-content-mid .govuk-tag {
font-style: normal;
}
.history-dest-change {
color: black;
}
.train-entry-arrow {
margin-right: 5px;
margin-left: 5px;
}
.history-transit-last {
font-style: normal;
color: #00703c;
font-weight: bold;
font-size: 1.5rem;
}
.history-dest {
background-color: #4c2c92;
font-weight: bold;
font-style: normal;
color: white;
padding: 0.4rem;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
}

462
trackernet.lisp

@ -19,8 +19,8 @@
(defparameter *train-set-code-expiry-secs* 360)
(defparameter *track-code-expiry-secs* 10)
(defparameter *rude-requests-per-minute* 300)
(defparameter *train-live-data-limit* 10000)
(defparameter *rescue-max-dist* 8.0)
(defparameter *train-live-data-limit* 40000)
(defparameter *rescue-max-dist* 10.0)
(defparameter *rescue-timediff-threshold* -15)
(defparameter *codes-to-scrape*
'(("D" "UPM") ; Upminster (terminus)
@ -61,14 +61,20 @@
("TDR.PBLA" "TD834")
("TD844B.A" "TD844C")
("TD846B" "TD844B.A")))
(defparameter *per-line-track-graph*
(alexandria:alist-hash-table
(mapcar
(lambda (pair)
(cons (car pair)
(alexandria:alist-hash-table
(car (cpk:decode-file (cadr pair)))
:test 'equal)))
'(("D" "./normalized-track-links.cpk")
("J" "./2021-04-19-jubilee-1.cpk")
("V" "./2021-04-19-victoria-1.cpk")))
:test 'equal))
(defparameter *normalized-track-links*
(or
(ignore-errors
(alexandria:alist-hash-table
(car
(cpk:decode-file "./normalized-track-links.cpk"))
:test 'equal))
(make-hash-table :test 'equal)))
(make-hash-table :test 'equal))
(defparameter +manual-count+ 999999)
(defvar *current-prediction* nil)
@ -236,6 +242,19 @@
departed direction is-stalled track-code line input-dest
leading-car-no)
(conspack:define-index trackernet-cpk-v1
;; trackernet-train
train-id lcid set-no trip-no seconds-to time-to location-desc
destination-desc dest-code order depart-time depart-interval
departed direction is-stalled track-code line input-dest
leading-car-no
;; trackernet-platform
name num next-train trains
;; trackernet-station
code cur-time platforms
;; trackernet-prediction
created-ts line-code line-name stations)
(defmethod print-object ((obj trackernet-prediction) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (line-name line-code created-ts stations) obj
@ -484,11 +503,13 @@
universal-ts))))
(defun cpk-base64 (object)
(qbase64:encode-bytes
(cpk:encode object)))
(cpk:with-named-index 'trackernet-cpk-v1
(qbase64:encode-bytes
(cpk:encode object))))
(defun cpk-unbase64 (data)
(cpk:decode (subseq (qbase64:decode-string data) 0)))
(cpk:with-named-index 'trackernet-cpk-v1
(cpk:decode (subseq (qbase64:decode-string data) 0))))
(defun get-all (pattern)
"Calls RED:SCAN in a loop, returning all the Redis keys matching PATTERN."
@ -527,6 +548,13 @@
(when data
(cpk-unbase64 data))))
(defun redis-paired-mget (key-names)
"Given a list of KEY-NAMES, returns an alist of each name paired with its value, or NIL if the value did not exist."
(loop
for key in key-names
for value in (apply #'red:mget key-names)
collect (cons key value)))
(defun redis-cpk-sorted-set-all (key)
"Gets all elements of the sorted set KEY, alongside their scores, CONSPACK-decoding each element."
(let ((data
@ -542,24 +570,18 @@
(defun redis-sorted-set-length (key)
(red:zcount key "-inf" "+inf"))
(defun nilify-zeros (str)
"If STR is not NIL and contains nothing or only zeroes, return NIL; otherwise, return STR."
(when (and str
(> (length (string-trim '(#\0) str)) 0))
str))
(defun redis-train (universal-ts line-code code-station train)
(with-slots (train-id set-no trip-no lcid seconds-to track-code location-desc leading-car-no) train
(when (and (or lcid train-id) seconds-to track-code)
(let* ((lcid (when (and lcid
(not (string= lcid "0"))
(not (string= lcid "")))
lcid))
(let* ((lcid (nilify-zeros lcid))
(tid (or lcid (format nil "tid~A" train-id)))
(tidmap-key (format nil "~A-tidmap-~A" line-code train-id))
(key (or (unless lcid (red:get tidmap-key))
(format nil "~A-train-~A" line-code tid))))
(when (and (not lcid) (red:get tidmap-key))
(log:warn "using TrainID map for ~A => ~A; very naughty TfL!"
tid key))
(when lcid
;; set a mapping of tid -> actual key used
(red:setnx tidmap-key key)
(red:expire tidmap-key *train-active-expiry-secs-real*))
(key (or (format nil "~A-train-~A" line-code tid))))
;; get a mapping of seconds to -> track code
(red:zadd (format nil "~A-secs-to-track-code"
code-station)
@ -569,9 +591,9 @@
(when (and location-desc
;; this is highly annoying
(not (string= location-desc "At Platform")))
(red:set (format nil "~A-track-desc-~A"
line-code track-code)
location-desc))
(red:setnx (format nil "~A-track-desc-~A"
line-code track-code)
location-desc))
;; add this train into the new list of trains for
;; the station
(red:sadd (format nil "~A-trains-new" code-station) key)
@ -599,7 +621,11 @@
universal-ts
;; include the station the train is from
;; for things like secondsto
(cpk-base64 (list code-station train)))))))
;; also include some random data, to minimize
;; the chance that this element is the same as some
;; previous element and redis scronches stuff
(cpk-base64 (list (format nil "~A-~A" code-station (random 256))
train)))))))
(defun maybe-redis-trackernet-prediction (pred)
(multiple-value-bind (filename universal-ts)
@ -661,10 +687,11 @@
(defun conspack-encode-to-archive (archive name data)
"Encode DATA into ARCHIVE in CONSPACK format, using the given NAME as filename."
(let* ((data (cpk:encode data))
(stream (flexi-streams:make-in-memory-input-stream data))
(header (make-fake-archive-entry name (length data))))
(archive:write-entry-to-archive archive header :stream stream)))
(cpk:with-named-index 'trackernet-cpk-v1
(let* ((data (cpk:encode data))
(stream (flexi-streams:make-in-memory-input-stream data))
(header (make-fake-archive-entry name (length data))))
(archive:write-entry-to-archive archive header :stream stream))))
(defun maybe-zstd-last-archive ()
"Runs `zstd` blocking-ly on yesterday's tar archive, if it exists."
@ -690,6 +717,10 @@
(red:set (format nil "rescue-ptr-~A"
to-be-archived)
new-train)
(red:del
(format nil "~A-rescue-~A"
(subseq new-train 0 1)
(subseq new-train #.(length "X-train-"))))
(loop
for (ts . data) in (redis-cpk-sorted-set-all to-be-archived)
do (red:zadd new-train ts (cpk-base64 data))))
@ -699,20 +730,21 @@
(mapcar
(lambda (x)
(cons
(format nil "~A-train-~A" line-code (subseq x #.(length "D-rescue-")))
(red:get x)))
(delete-if
(lambda (x)
;; This is kind of subtle: to prevent old trains screwing up
;; the rescue of new trains, we add a grace period to the TTL
;; of the rescue key that's the length of time it takes for
;; an active train to become inactive (plus a few seconds).
;;
;; This means that an old train can't snatch new trains until
;; trains that could conceivably have just expired and be
;; the most likely candidate have had their go.
(> (red:ttl x) *train-active-expiry-secs-real*))
(get-all (format nil "~A-rescue-*" line-code)))))
(format nil "~A-train-~A" line-code (subseq (car x) #.(length "D-rescue-")))
(cdr x)))
(redis-paired-mget
(delete-if
(lambda (x)
;; This is kind of subtle: to prevent old trains screwing up
;; the rescue of new trains, we add a grace period to the TTL
;; of the rescue key that's the length of time it takes for
;; an active train to become inactive (plus a few seconds).
;;
;; This means that an old train can't snatch new trains until
;; trains that could conceivably have just expired and be
;; the most likely candidate have had their go.
(> (red:ttl x) *train-active-expiry-secs-real*))
(get-all (format nil "~A-rescue-*" line-code))))))
(defun get-dijkstra-path (previous-table goal)
(nreverse
@ -766,7 +798,8 @@
(list goal))))
(defun find-rescuable-train-dijkstra (start line-code &key stop-after-dist)
(when (string= line-code "D")
(alexandria:when-let ((*normalized-track-links*
(gethash line-code *per-line-track-graph*)))
(let ((rescuable (get-rescuable-trains line-code)))
(mapcar
(lambda (train-and-code)
@ -780,7 +813,7 @@
"Formats a rescue path, putting -> arrows between codes."
(format nil "~{~A~^ -> ~}" rescue-path))
(defun maybe-rescue-train (key)
(defun maybe-rescue-train (key &key just-return-distance)
"Figure out whether the train with key KEY can be rescued. If it can, rescue it, returning (VALUES NEW-CODE DISTANCE CODE-PATH)."
(let* ((last-data (cadr (redis-last-cpk key)))
(last-ts (redis-last-score key))
@ -794,6 +827,8 @@
:key #'cadr)))
(dolist (candidate rescue-candidates)
(destructuring-bind (new-code distance code-path) candidate
(when just-return-distance
(return-from maybe-rescue-train distance))
;; if this and future candidates are above the max dist, stop
;; considering candidates
(when (> distance *rescue-max-dist*)
@ -859,7 +894,6 @@
(if (and (> (redis-last-score key)
(- (get-universal-time) *train-active-expiry-secs-real*))
(< (redis-sorted-set-length key) *train-live-data-limit*)
(string= (subseq key 0 1) "D")
(not archive-all))
(multiple-value-bind (new-code dist path timediff)
(maybe-rescue-train key)
@ -882,9 +916,10 @@
(sort
(mapcar
(lambda (key)
(cons (subseq key #.(length "D-code-archives-"))
(parse-integer (red:get key))))
(get-all (format nil "~A-code-archives-*" line-code)))
(cons (subseq (car key) #.(length "D-code-archives-"))
(parse-integer (cdr key))))
(redis-paired-mget
(get-all (format nil "~A-code-archives-*" line-code))))
#'>
:key #'cdr))
@ -931,7 +966,8 @@
func
(cons
filename
(cpk:decode data))))))))))))
(cpk:with-named-index 'trackernet-cpk-v1
(cpk:decode data)))))))))))))
(defun scraper-loop (line-code station-code)
"Scrape the station with the given codes every *TRACKERNET-SCRAPE-INTERVAL* in a loop, calling MAYBE-WRITE-TRACKERNET-PREDICTION with each scrape result.
@ -972,6 +1008,9 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(get-all (format nil "~A-active-*"
line-code)))
(defun old-active-keys (line-code)
(delete-if #'red:get (trains-active-on-line line-code)))
(defun all-trains-with-sizes ()
(sort
(mapcar
@ -993,10 +1032,15 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Archive all trains that have expired."
(let ((trains (get-archivable-trains)))
(unless (null trains)
;; sort the trains latest-to-earliest,
;; so trains that just dropped out can be quickly rescued
(sort trains #'>
:key #'redis-last-score)
;; sort trains in order of smallest rescue distance, to avoid
;; faraway trains screwing up closer trains
(setf trains (sort trains #'<
:key (lambda (trn)
(or
(maybe-rescue-train
trn
:just-return-distance t)
sb-ext:double-float-positive-infinity))))
(statsd-gauge "intertube.maybe-archivable" (length trains))
(handler-case
(archive-trains-tar trains)
@ -1033,8 +1077,6 @@ 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))
(log:info "~A nodes in normalized track graph"
(hash-table-size *normalized-track-links*))
(log:info "starting ~A scrapers, ~A requests/min..."
(length codes) rpm))
(setf *trackernet-kill-switch* nil)
@ -1072,10 +1114,11 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Returns an alist of all track codes and their textual descriptions for the given LINE-CODE."
(mapcar
(lambda (key)
(cons (subseq key #.(length "X-track-desc-"))
(red:get key)))
(get-all (format nil "~A-track-desc-*"
line-code))))
(cons (subseq (car key) #.(length "X-track-desc-"))
(cdr key)))
(redis-paired-mget
(get-all (format nil "~A-track-desc-*"
line-code)))))
(defun reset-track-links-set ()
(setf *track-links-set* (make-hash-table
@ -1150,72 +1193,78 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(cpk:encode (alexandria:hash-table-alist *normalized-track-links*)
:stream stream)))
(defun write-mini-graphviz (around-codes &key (out *standard-output*) (neato nil))
(defun write-mini-graphviz (around-codes line-code &key (out *standard-output*) (neato nil))
"Write out a mini graph containing the nodes around AROUND-CODE in graphviz format."
(princ "digraph {" out)
(terpri out)
(princ "node [shape=box margin=\"0.1,0.1\"];" out)
(terpri out)
(if neato
(progn
(princ "layout = \"neato\";" out)
(terpri out))
(progn
(princ "rankdir = LR;" out)
(terpri out)))
(let ((nodes around-codes)
(nodes-1 '())
(links '()))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (member src around-codes :test #'string=)
do (dolist (dest dests)
(pushnew (car dest) nodes
:test #'string=)
(push (list src (car dest) (cadr dest))
links))
unless (member src around-codes :test #'string=)
do (loop
for (dest dist) in dests
when (member dest around-codes :test #'string=)
do (pushnew src nodes
:test #'string=)
when (member dest around-codes :test #'string=)
do (push
(list src dest dist)
links)))
(setf nodes-1 (copy-seq nodes))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (and (member src nodes-1 :test #'string=)
(not (member src around-codes :test #'string=)))
do (dolist (dest dests)
(unless (member (car dest) around-codes :test #'string=)
(let ((*normalized-track-links*
(gethash line-code *per-line-track-graph*)))
(princ "digraph {" out)
(terpri out)
(princ "node [shape=box margin=\"0.1,0.1\"];" out)
(terpri out)
(if neato
(progn
(princ "layout = \"neato\";" out)
(terpri out))
(progn
(princ "rankdir = LR;" out)
(terpri out)))
(let ((nodes around-codes)
(nodes-1 '())
(links '()))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (member src around-codes :test #'string=)
do (dolist (dest dests)
(pushnew (car dest) nodes
:test #'string=)
:test #'string=)
(push (list src (car dest) (cadr dest))
links))))
(loop
with value
for node in nodes
do (setf value (red:get (format nil "D-track-desc-~A" node)))
do (format out "\"~A\" [fillcolor=~A style=filled label=<<B>~A</B><BR /><I><FONT POINT-SIZE=\"10\">~{~A~^<BR ALIGN=\"LEFT\"/>~}</FONT></I>>]~%"
node
(if (member node around-codes :test #'string=)
"lightblue1"
"white")
node
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(loop
for (src dest dist) in links
do (format out "\"~A\" -> \"~A\" [len=~F];~%"
src dest dist))
(princ "}" out)
(terpri out)))
links))
unless (member src around-codes :test #'string=)
do (loop
for (dest dist) in dests
when (member dest around-codes :test #'string=)
do (pushnew src nodes
:test #'string=)
when (member dest around-codes :test #'string=)
do (push
(list src dest dist)
links)))
(setf nodes-1 (copy-seq nodes))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (and (member src nodes-1 :test #'string=)
(not (member src around-codes :test #'string=)))
do (dolist (dest dests)
(unless (member (car dest) around-codes :test #'string=)
(pushnew (car dest) nodes
:test #'string=)
(push (list src (car dest) (cadr dest))
links))))
(loop
for node in nodes
for (nil . value) in (redis-paired-mget
(mapcar
(lambda (node)
(format nil "~A-track-desc-~A"
line-code node))
nodes))
do (format out "\"~A\" [fillcolor=~A style=filled label=<<B>~A</B><BR /><I><FONT POINT-SIZE=\"10\">~{~A~^<BR ALIGN=\"LEFT\"/>~}</FONT></I>>]~%"
node
(if (member node around-codes :test #'string=)
"lightblue1"
"white")
node
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(loop
for (src dest dist) in links
do (format out "\"~A\" -> \"~A\" [len=~F];~%"
src dest dist))
(princ "}" out)
(terpri out))))
(defun write-track-links-graphviz (&key (out *standard-output*) (cutoff 20))
"Write the track links out in graphviz format."
@ -1225,9 +1274,8 @@ layout = \"neato\";")
(terpri out)
(format *debug-io* "*** Writing track descriptions~%")
(loop
for key in (get-all "D-track-desc-*")
for (key . value) in (redis-paired-mget (get-all "J-track-desc-*"))
for actual = (subseq key 13)
for value = (red:get key)
do (format out "\"~A\" [label=<<B>~A</B><BR /><I><FONT POINT-SIZE=\"10\">~{~A~^<BR ALIGN=\"LEFT\"/>~}</FONT></I>>]~%"
actual
actual
@ -1380,16 +1428,166 @@ color=lightblue;
do (format out "\"~A\" -> \"~A\" [weight=~A label=\"~A\"];~%" a b v v))
(princ "}" out))
(defun populate-track-links (train-list)
(defun populate-track-links (train-list &key match)
(reset-track-links-set)
(loop
for train in train-list
do (format t "~&*** Processing train ~A...~%" train)
do (time (with-simple-restart (next-file "Move on to the next file.")
(unarchive-trains-tar train #'populate-track-links-set))))
(unarchive-trains-tar train #'populate-track-links-set
:match match))))
(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)))
(defclass train-history-entry ()
((universal-ts
:initarg :universal-ts
:reader universal-ts)))
(defclass train-identity-change (train-history-entry)
((wtt-id
:initarg :wtt-id
:reader wtt-id)
(wtt-trip
:initarg :wtt-trip
:reader wtt-trip)))
(defun universal-time-railway (time)
(local-time:with-decoded-timestamp
(:sec s :minute m :hour h
:timezone trackernet::+europe-london-tz+)
(local-time:universal-to-timestamp time)
(format nil
"~2,'0D~2,'0D~A" h m
(cond
((>= s 45) "¾")
((>= s 30) "½")
((>= s 15) "¼")
(t "")))))
(defmethod print-object ((obj train-identity-change) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts wtt-id wtt-trip) obj
(format stream "at ~A: WTT ~A×~A"
(universal-time-railway universal-ts)
(or wtt-id "?")
(or wtt-trip "?")))))
(defclass train-destination-change (train-history-entry)
((destination
:initarg :destination
:reader destination)))
(defmethod print-object ((obj train-destination-change) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts destination) obj
(format stream "at ~A: destination ~A"
(universal-time-railway universal-ts)
destination))))
(defclass train-transit (train-history-entry)
((end-ts
:initarg :end-ts
:accessor end-ts)
(track-codes
:initarg :track-codes
:initform '()
:accessor track-codes)))
(defmethod print-object ((obj train-transit) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts end-ts track-codes) obj
(format stream "from ~A to ~A: ~A"
(universal-time-railway universal-ts)
(universal-time-railway end-ts)
(format-path track-codes)))))
(defclass train-station-stop (train-transit)
((station-name
:initarg :station-name
:reader station-name)
(platform
:initarg :platform
:reader platform)))
(defmethod print-object ((obj train-station-stop) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts end-ts track-codes station-name platform) obj
(format stream "from ~A to ~A: ~As at ~A (plat ~A), ~A"
(universal-time-railway universal-ts)
(universal-time-railway end-ts)
(- end-ts universal-ts)
station-name
platform
(format-path track-codes)))))
(defun extract-station-information (description)
(when (uiop:string-prefix-p "At " description)
(cl-ppcre:register-groups-bind (station-name platform)
("At (.+) Platform (.+)" description)
(return-from extract-station-information
(values station-name platform)))
(values (subseq description #.(length "At ")) nil)))
(defun make-train-history (train-id &key cached-descriptions)
"Return a list of train history entries for the given TRAIN-ID."
(let* ((current-identity nil)
(current-destination nil)
(current-entry nil)
(line-code (subseq train-id 0 1))
(track-descriptions (or cached-descriptions
(line-track-descriptions line-code)))
(ret nil))
(dolist (entry (sort (redis-cpk-sorted-set-all train-id) #'<
:key #'first))
(destructuring-bind (universal-ts observer train) entry
(declare (ignore observer))
(let* ((identity (list (nilify-zeros (set-no train))
(nilify-zeros (trip-no train))))
(descr (cdr (assoc (track-code train) track-descriptions
:test #'string=)))
(destination (or (destination-desc train)
"<somewhere>")))
(unless (equal destination current-destination)
(setf current-destination destination)
(push (make-instance 'train-destination-change
:destination destination
:universal-ts universal-ts)
ret))
(unless (equal identity current-identity)
(setf current-identity identity)
(push (make-instance 'train-identity-change
:wtt-id (first identity)
:wtt-trip (second identity)
:universal-ts universal-ts)
ret))
(multiple-value-bind (station-name platform)
(extract-station-information descr)
(unless (and current-entry
(eql (when station-name t)
(typep current-entry 'train-station-stop)))
(unless (eql current-entry nil)
(setf (end-ts current-entry) universal-ts)
(setf (track-codes current-entry)
(nreverse (track-codes current-entry)))
(push current-entry ret))
(setf current-entry
(if station-name
(make-instance 'train-station-stop
:station-name station-name
:platform platform
:universal-ts universal-ts
:end-ts universal-ts)
(make-instance 'train-transit
:universal-ts universal-ts
:end-ts universal-ts)))))
(pushnew (track-code train) (track-codes current-entry)
:test #'string=)
(setf (end-ts current-entry) universal-ts))))
(when current-entry
(push current-entry ret))
ret))

270
wobsite.lisp

@ -129,6 +129,11 @@
<path fill=\"currentColor\" d=\"M0 0h13l20 20-20 20H0l20-20z\" />
</svg>")
(defparameter *govuk-go-arrow-standalone-svg*
"<svg class=\"train-entry-arrow\" 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>")
(defparameter *govuk-go-arrow-small-svg*
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"8.75\" height=\"9.5\" viewBox=\"0 0 33 40\" aria-hidden=\"true\" focusable=\"false\">)
<path fill=\"currentColor\" d=\"M0 0h13l20 20-20 20H0l20-20z\" />
@ -171,7 +176,7 @@
(format nil
"~2,'0D:~2,'0D:~2,'0D" h m s)))
(defun mini-graphviz-stream (around-codes)
(defun mini-graphviz-stream (around-codes line-code)
(let* ((proc
(uiop:launch-program
'("dot" "-Tpng")
@ -183,7 +188,7 @@
(uiop:process-info-input proc)
:external-format :utf-8)))
(unwind-protect
(trackernet::write-mini-graphviz around-codes :out viz-in)
(trackernet::write-mini-graphviz around-codes line-code :out viz-in)
(close viz-in))
(uiop:process-info-output proc)))
@ -221,7 +226,7 @@
(hunchentoot:abort-request-handler "get a better hmac mate"))
(setf (hunchentoot:content-type*) "image/png")
(let* ((out (hunchentoot:send-headers))
(in (mini-graphviz-stream actual-around)))
(in (apply #'mini-graphviz-stream actual-around)))
(unwind-protect
(loop
for byte = (read-byte in nil nil)
@ -229,7 +234,132 @@
do (write-byte byte out))
(close in)))))
(defun display-trackernet-train (train &key code ts reporter distance show-dest maybe-hide-codes)
(defun format-duration (secs)
(if (> secs 60)
(format nil "~Am ~As" (floor secs 60) (rem secs 60))
(format nil "~As" secs)))
(defun universal-time-train2 (time)
(local-time:with-decoded-timestamp
(:sec s :minute m :hour h
:timezone trackernet::+europe-london-tz+)
(local-time:universal-to-timestamp time)
(format nil
"~2,'0D~2,'0D~A" h m
(cond
((>= s 45) "<small>¾</small>")
((>= s 30) "<small>½</small>")
((>= s 15) "<small>¼</small>")
(t "")))))
(defun track-codes-from-history-entries (ents)
(dolist (ent ents)
(when (typep ent 'trackernet::train-transit)
(return-from track-codes-from-history-entries
(trackernet::track-codes ent))))
nil)
(defun display-train-history-entry (ent line-code &key lastp)
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
(:li
:class (if lastp
"train-history-entry train-history-last"
"train-history-entry")
(when (typep ent 'trackernet::train-station-stop)
(who:htm
(:span
:class "history-entry-time"
(who:str (universal-time-train2
(trackernet::universal-ts ent))))))
(:span
:class (if (typep ent 'trackernet::train-station-stop)
"history-content-large" "history-content-mid")
(etypecase ent
(trackernet::train-destination-change
(who:htm
(:span
:class "history-dest-change"
(:strong
:class "history-dest"
(who:str (trackernet::destination ent)))
" is now this train's destination")))
(trackernet::train-station-stop
(who:htm
(:span
:class "history-station-stop"
(:strong
:class "history-station"
(when lastp
(who:str *govuk-go-arrow-standalone-svg*)
(who:str " "))
(who:str (trackernet::station-name ent)))
(:span
:class "history-station-platform"
(when (trackernet::platform ent)
(who:htm
(:span
:class "no-phones"
" plat. "
(:strong
:class "history-platform"
(who:str (trackernet::platform ent)))
" ")))
" for "
(:span
:class (concatenate
'string
"history-station-dwell "
(if (> (- (trackernet::end-ts ent)
(trackernet::universal-ts ent))
60)
"history-dwell-tardy"
""))
(who:esc (format-duration
(- (trackernet::end-ts ent)
(trackernet::universal-ts ent)))))))))
(trackernet::train-transit
(who:htm
(:span
:class "history-transit"
(when lastp
(who:htm
(:span
:class "history-transit-last"
(who:str *govuk-go-arrow-standalone-svg*)
" "
(who:esc (or
(cdr (assoc (first (trackernet::track-codes ent))
(cached-track-suggestions line-code)
:test #'string=))
(format nil "Location unknown (~A)"
(first (trackernet::track-codes ent)))))
" ")))
"in transit for "
(who:esc (format-duration
(- (trackernet::end-ts ent)
(trackernet::universal-ts ent)))))))
(trackernet::train-identity-change
(if (trackernet::wtt-id ent)
(let* ((class (if (trackernet::wtt-trip ent)
"govuk-tag govuk-tag--purple"
"govuk-tag govuk-tag--green")))
(who:htm
(:span
:class "history-ident-change"
"assigned timetable ID "
(:strong
:class class
(who:esc (trackernet::wtt-id ent))
(when (trackernet::wtt-trip ent)
(who:str " ×")
(who:esc (trackernet::wtt-trip ent)))))))
(who:htm
(:span
:class "history-ident-lost"
"lost timetable assignment")))))))))
(defun display-trackernet-train (train line-code &key code ts reporter distance show-dest maybe-hide-codes)
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
(:tr
@ -276,7 +406,7 @@
(:span
(who:esc (or
(cdr (assoc (trackernet::track-code train)
(cached-track-suggestions "D")
(cached-track-suggestions line-code)
:test #'string=))
(trackernet::location-desc train)
"<somewhere>"))
@ -295,7 +425,7 @@
(who:htm
(:a
:class "govuk-link"
:href (format nil "/train?train=~A"
:href (format nil "/train2?train=~A"
code)
"[more]")
(who:str " ")))
@ -315,7 +445,9 @@
"Stale")))
(:a
:href (multiple-value-bind (around hmac)
(trusted-serialize (list (trackernet::track-code train)))
(trusted-serialize (list
(list (trackernet::track-code train))
line-code))
(format nil "/miniviz?around=~A&hmac=~A"
(hunchentoot:url-encode
around)
@ -328,6 +460,117 @@
(defparameter *max-train-lines* 100)
(hunchentoot:define-easy-handler (train-simple :uri "/train2") (train)
(when (< (length train) #.(length "X-train-Y"))
(setf (hunchentoot:return-code*) 400)
(hunchentoot:abort-request-handler
(format nil "bad train id mate: ~A" train)))
(unless (red:exists train)
(alexandria:when-let ((new-train (red:get (format nil "rescue-ptr-~A" train))))
;; train got rescued into another train
(hunchentoot:redirect (format nil "/train2?train=~A" new-train)))
(setf (hunchentoot:return-code*) 404)
(hunchentoot:abort-request-handler "not found lol"))
(let* ((line-code (subseq train 0 1))
(line-data (tube-line-by-code line-code))
(last-train-data (second (trackernet::redis-last-cpk train)))
(secs-new (- (get-universal-time) (trackernet::redis-first-score train)))
(secs-old (- (get-universal-time) (trackernet::redis-last-score train)))
(train-data (trackernet::make-train-history
train
:cached-descriptions (cached-track-suggestions line-code)))
(viz-data (multiple-value-list
(trusted-serialize
(list
(track-codes-from-history-entries train-data)
line-code))))
(first t)
(*accent-colour* (apply #'html-rgb-colour (third line-data))))
(render ()
(:a
:class "govuk-back-link"
:href (format nil "/line?code=~A"
line-code)
(who:fmt "~A line"
(first line-data)))
(:span
:class "govuk-caption-xl"
"Train history for "
(:span
:class "id-field"
(who:str train)))
(:h1
:class "govuk-heading-xl"
(who:fmt "Train to ~A "
(or
(trackernet::destination-desc
last-train-data)
"nowhere")))
(when (< secs-new 45)
(who:htm
(:div
:class "govuk-warning-text"
(:span
:class "govuk-warning-text__icon"
"!")
(:strong
:class "govuk-warning-text__text"
"This train might be missing data. Please wait a few moments while we attempt to find more history."))))
(cond
((> secs-old 120)
(who:htm
(:div
:class "govuk-warning-text"
(:span
:class "govuk-warning-text__icon"
"!")
(:strong
:class "govuk-warning-text__text"
"We seem to have lost track of this train, due to gaps in our open data sources."))))
((> secs-old 15)
(who:htm
(:div
:class "govuk-warning-text"
(:span
:class "govuk-warning-text__icon"
"!")
(:strong
:class "govuk-warning-text__text"
"This train's data is currently delayed by about a minute.")))))
(:details
:class "govuk-details"
(:summary
:class "govuk-details__summary"
(:span
:class "govuk-details__summary-text"
"Details for nerds"))
(:div
:class "govuk-details__text"
(:p
:class "govuk-body"
"Track code graph (shows intertube's view of the network):")
(:img
:class "miniviz"
:src (format nil "/miniviz?around=~A&hmac=~A"
(hunchentoot:url-encode
(car viz-data))
(hunchentoot:url-encode
(cadr viz-data))))
(:p
:class "govuk-body"
"View "
(:a
:class "govuk-link"
:href (format nil "/train?train=~A" train)
"the raw Trackernet data")
" for more granular information.")))
(:ul
:class "govuk-list"
(dolist (ent train-data)
(who:str (display-train-history-entry ent line-code :lastp first))
(when first
(setf first nil)))))))
(hunchentoot:define-easy-handler (train :uri "/train") (train limit)
(when limit
(unless (setf limit (ignore-errors (parse-integer limit)))
@ -352,7 +595,11 @@
(last-train-obj (third (car (last train-data))))
(last-track-code (trackernet::track-code last-train-obj))
(secs-old (- (get-universal-time) (trackernet::redis-last-score train)))
(viz-data (multiple-value-list (trusted-serialize (list last-track-code))))
(viz-data (multiple-value-list
(trusted-serialize
(list
(list last-track-code)
line-code))))
(max-to-show (min train-data-len
(or limit *max-train-lines*)))
(lcids '())
@ -478,6 +725,7 @@
(equal last (trackernet::track-code train))
(>= i max-to-show))
do (who:str (display-trackernet-train train
line-code
:ts ts
:show-dest (not (string= (trackernet::destination-desc train) last-dest))
:reporter reporter))
@ -503,6 +751,9 @@
(defun trains-by-dijkstra-from (linecode trackcode)
"Returns a sorted list of (DISTANCE TRAIN-ID TRAIN) lists for all trains on the given line (LINECODE), ordered by their Dijkstra-determined distance from the given TRACKCODE."
(let* ((objects (train-objects-on-line linecode))
(trackernet::*normalized-track-links*
(gethash linecode
trackernet::*per-line-track-graph*))
(distanced-objects
(mapcar
(lambda (tlist)
@ -618,6 +869,7 @@
(loop
for (distance key train) in train-list
do (who:str (display-trackernet-train train
linecode
:distance distance
:maybe-hide-codes t
:show-dest t
@ -801,7 +1053,7 @@
for (key reporter train) in (sort trains #'string<
:key (lambda (trn)
(trackernet::train-id (third trn))))
do (who:str (display-trackernet-train train :code key)))))))))))
do (who:str (display-trackernet-train train code :code key)))))))))))
(hunchentoot:define-easy-handler (root :uri "/") ()
(render ()

Loading…
Cancel
Save