eta
/
intertube
1
0
Fork 0
Code Issues Pull Requests Projects Releases Activity
Browse Source

redesign, no tidmap, indexing, mgets, rescue improvements

master
eta 2 months ago
parent
0467b3a721
commit
6ae9493f22
4 changed files with 677 additions and 142 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 2
      deploy.txt
  2. 85
      govuk.css
  3. 462
      trackernet.lisp
  4. 270
      wobsite.lisp

2
deploy.txt
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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 ()

Write Preview
Loading…
Cancel
Save