Browse Source

Assorted bug fixes & improvements

master
eta 2 months ago
parent
commit
ed09fe6731
  1. 43
      archive-hacks.lisp
  2. 3
      deploy-web.sh
  3. 3
      deploy.txt
  4. 3
      govuk.css
  5. BIN
      normalized-track-links.cpk
  6. BIN
      track-links-good-20210403.cpk
  7. 421
      trackernet.lisp
  8. 164
      wobsite.lisp

43
archive-hacks.lisp

@ -0,0 +1,43 @@
(in-package :archive)
(defun fast-io-transfer (archive entry stream rounding-function)
(when (data-discarded-p entry)
;; by definition, there's nothing left
(return-from fast-io-transfer (values)))
(let* ((entry-stream (entry-stream entry))
(n-bytes-remaining (n-bytes-remaining entry-stream))
(rounded-size (funcall rounding-function (size entry)))
(rounded-n-bytes-remaining (- rounded-size
(- (size entry) n-bytes-remaining))))
(fast-io:with-fast-input (asbuf nil (archive-stream archive))
(loop with buffer = (make-array (* 64 1024) :element-type '(unsigned-byte 8))
for bytes-read = (fast-io:fast-read-sequence buffer asbuf
0
(min (length buffer)
rounded-n-bytes-remaining))
do (assert (not (minusp n-bytes-remaining)))
(decf rounded-n-bytes-remaining bytes-read)
(fast-io:fast-write-sequence buffer stream
0 (min n-bytes-remaining bytes-read))
(decf n-bytes-remaining bytes-read)
while (plusp rounded-n-bytes-remaining)))
;; make sure we didn't overrun the data of the entry
(assert (zerop rounded-n-bytes-remaining))
;; make sure nobody can read from the entry's stream
(setf (n-bytes-remaining entry-stream) 0)
;; indicate that we've already discarded the data
(setf (data-discarded-p entry) t)
(values)))
(defmethod transfer-entry-data-to-stream ((archive tar-archive)
(entry tar-entry)
(stream fast-io:output-buffer))
(fast-io-transfer archive entry stream #'round-up-to-tar-block))
(let ((archive-fucky-method
(ignore-errors
(find-method #'initialize-instance '(:after) (list (find-class 'archive:archive))))))
(when archive-fucky-method
(warn "ARCHIVE is stupid, un-stupiding")
(remove-method #'initialize-instance archive-fucky-method)))

3
deploy-web.sh

@ -0,0 +1,3 @@
#!/bin/sh
echo '*** NB: press Enter after the text stops scrolling past!'
sbcl < deploy-web.txt

3
deploy.txt

@ -1,5 +1,6 @@
(ql:quickload '(drakma cl-conspack cxml cl-statsd cl-redis qbase64 archive cl-ansi-text gzip-stream bobbin))
(ql:quickload '(drakma cl-conspack cxml cl-statsd cl-redis qbase64 archive cl-ansi-text gzip-stream bobbin cl-heap))
(load "trackernet.lisp")
(format t "** Loaded ~A track links **~%" (hash-table-size trackernet::*normalized-track-links*))
(sb-ext:save-lisp-and-die "./intertube-scraper" :toplevel #'trackernet::main :executable t)

3
govuk.css

@ -17,3 +17,6 @@
display: none;
}
}
.train-to {
color: #505a5f;
}

BIN
normalized-track-links.cpk

Binary file not shown.

BIN
track-links-good-20210403.cpk

Binary file not shown.

421
trackernet.lisp

@ -396,7 +396,7 @@
(defparameter *trackernet-scrape-interval* 2.5)
(defparameter *trackernet-kill-switch* nil)
(defparameter *prediction-expiry-secs* 60)
(defparameter *train-active-expiry-secs* 180)
(defparameter *train-active-expiry-secs* 300)
(defparameter *train-set-code-expiry-secs* 360)
(defparameter *rude-requests-per-minute* 300)
@ -556,6 +556,15 @@
(when score
(parse-integer score))))
(defun redis-first-score (key)
"Gets the score of the first element of the sorted set with the Redis KEY."
(let ((score (second
(red:zrangebyscore key "-inf" "+inf"
:limit (cons "0" "1")
:withscores t))))
(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
@ -579,10 +588,14 @@
(defun get-archivable-trains ()
"Returns a list of all trains that were last updated more than *TRAIN-ACTIVE-EXPIRY-SECS* ago."
(let* ((trains (get-all "D-train-*"))
(cutoff (- (get-universal-time) *train-active-expiry-secs*)))
(let* ((trains (get-all "?-train-*"))
(cutoff (- (get-universal-time) *train-active-expiry-secs*))
(dst-cutoff (- (+ 3600 (get-universal-time))
*train-active-expiry-secs*)))
(delete-if-not (lambda (train)
(< (redis-last-score train) cutoff))
(or
(< (redis-last-score train) dst-cutoff)
(< (redis-last-score train) cutoff)))
trains)))
(defun get-iso-8601-date ()
@ -651,7 +664,17 @@
"~&archiver: failed to pigz last archive: code ~A~%"
exit-code))))))
(defparameter *rescue-depth* 3)
(defparameter *rescue-max-dist* 8.0)
(defun rescue-train (to-be-archived new-train)
"Copy records from the train with key TO-BE-ARCHIVED into the NEW-TRAIN."
(statsd-inc "intertube.rescues")
(red:set (format nil "rescue-ptr-~A"
to-be-archived)
new-train)
(loop
for (ts . data) in (redis-cpk-sorted-set-all to-be-archived)
do (red:zadd new-train ts (cpk-base64 data))))
(defun archive-trains-tar (keys)
"Archive trains from KEYS, a list of Redis train sorted set keys."
@ -672,29 +695,55 @@
(loop
for train in trains-data
do (let ((last-data
(third (car (last (car (last train)))))))
(third (car (last (car (last train))))))
(*print-right-margin* nil))
(format
t
"~&archiver: ~Aarchiving ~A~A: ~A~%"
"~&archiver: ~Aarchiving ~A (~A recs)~A: ~A~%"
(cl-ansi-text:make-color-string :red :style :background)
(second train)
(length (car (last train)))
cl-ansi-text:+reset-color-string+
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)
(second train))
train)))))
(block continue
(loop
for (new-code distance code-path)
in (sort (find-rescuable-train-dijkstra (track-code last-data) (subseq (second train) 0 1)) #'< :key #'cadr)
do (format
t
"~&archiver: could rescue with: ~a @ ~a: ~A steps, ~A secs~%"
new-code
distance
(length code-path)
(- (redis-first-score new-code)
(first train)))
unless (or
(< (- (redis-first-score new-code)
(first train))
0)
(string= new-code (second train))
(> distance *rescue-max-dist*))
do (format
t
"~&archiver: ~adoing rescue with~a: ~a @ ~a: ~{~a~^ -> ~}~%"
(cl-ansi-text:make-color-string :cyan :style :background)
cl-ansi-text:+reset-color-string+
new-code
distance
code-path)
(rescue-train (second train) new-code)
(red:incr (format nil "~A-code-rescues-~A"
(subseq (second train) 0 1)
(track-code last-data)))
(return-from continue))
(red:incr (format nil "~A-code-archives-~A"
(subseq (second train) 0 1)
(track-code last-data)))
(conspack-encode-to-archive tar
(format nil "~A-~A.trn"
(first train)
(second train))
train)))))))
(defun archive-entry-filename (entry)
(cond
@ -702,31 +751,44 @@
(namestring (archive::entry-pathname entry)))
(t (archive::name entry))))
(defun make-pigz-decompressing-stream (in)
(uiop:process-info-output
(uiop:launch-program
"pigz -d"
:input in
:element-type '(unsigned-byte 8)
:output :stream)))
(defun unarchive-trains-tar (path func &key match (gzip-encoded (uiop:string-suffix-p path "gz")))
"Read trains from the archive at PATH, running FUNC on each decoded train object."
(with-open-file (in path
:direction :input
:element-type '(unsigned-byte 8))
(archive:with-open-archive (tar
(if gzip-encoded
(gzip-stream:make-gzip-input-stream in)
in)
:direction :input)
(ignore-errors ; The archive probably isn't going to be terminated
(archive:do-archive-entries (entry tar)
(let ((buf (flexi-streams:make-in-memory-output-stream))
(filename (ignore-errors (archive-entry-filename entry))))
(when (or
(not match)
(cl-ppcre:scan match filename))
(archive::transfer-entry-data-to-stream tar entry buf)
(funcall
func
(cons
filename
(cpk:decode
(subseq
(flexi-streams:get-output-stream-sequence buf) 0)))))))))))
(handler-bind
((simple-error
(lambda (c)
(if (string= (princ-to-string c) "Corrupt archive")
(return-from unarchive-trains-tar)
(invoke-debugger c)))))
(archive:with-open-archive (tar
(if gzip-encoded
(make-pigz-decompressing-stream in)
in)
:direction :input)
(archive:do-archive-entries (entry tar)
(with-simple-restart (next-entry "Skip the current entry.")
(let ((buf (fast-io:make-output-buffer))
(filename (ignore-errors (archive-entry-filename entry))))
(when (or
(not match)
(cl-ppcre:scan match filename))
(archive::transfer-entry-data-to-stream tar entry buf)
(let ((data (fast-io:finish-output-buffer buf)))
(funcall
func
(cons
filename
(cpk:decode data))))))))))))
(defun archive-trains (keys)
"Archive trains from KEYS, a list of Redis train sorted set keys."
@ -812,6 +874,16 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(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))))
;; Stupid USOCKET doesn't make its condition classes subtypes of ERROR,
;; so let's catch them separately. Well done.
(usocket:ns-condition (e)
(statsd-inc (format nil "scraper.~A-~A.errors" line-code station-code))
(format *error-output* "~&scraper(~A-~A): resolver failed: ~A~%"
line-code station-code e))
(usocket:socket-condition (e)
(statsd-inc (format nil "scraper.~A-~A.errors" line-code station-code))
(format *error-output* "~&scraper(~A-~A): socket error: ~A~%"
line-code station-code e))
(error (e)
(statsd-inc (format nil "scraper.~A-~A.errors" line-code station-code))
(format *error-output* "~&scraper(~A-~A): error: ~A~%"
@ -868,6 +940,10 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(unless (null trains)
(format t "~&archiver: ~A archivable trains~%"
(length trains))
;; sort the trains earliest-to-latest,
;; so rescue chaining has a chance of working
(sort trains #'<
:key #'redis-last-score)
(handler-case
(progn
(archive-trains-tar trains)
@ -906,8 +982,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 "~&~A nodes in normalized track graph~%"
(hash-table-size *normalized-track-links*))
(format t "~&starting ~A scrapers, ~A requests/min...~%"
(length codes) rpm))
(setf *trackernet-kill-switch* nil)
@ -1067,16 +1143,52 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
while next
do (let ((track-code-1 (track-code (third first)))
(track-code-2 (track-code (third next))))
(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))))
(unless (string= track-code-1 track-code-2)
(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))))
do (setf first next))))
(defparameter +manual-count+ 999999)
(defparameter *replaced-track-links-set* (make-hash-table
:test 'equal))
(defun add-manual-track-link (src dest)
(setf (gethash (list src dest) *replaced-track-links-set*)
(gethash (list src dest) *track-links-set*))
(setf (gethash (list src dest) *track-links-set*)
+manual-count+))
(defparameter *manuals*
'(("TPAE.AF" "TPAG")
("TBSWEK" "TDBT-598WEK")
("TDHPSOK" "TDHSSOK")
("TDHL-HK-HJGLR" "TD762BA")
("TDBDEAC" "TDBE-BFEAC")
("TD788D.C" "TD782.784")
("TD776D.C" "TD770A.774")
("TD800" "TD798B.A")
("TDCHEMB" "TDCJEMB")
("TD820" "TDCD.CBEMB")
("TD828B" "TD824C.B.A")
("TD828A" "TD828B")
("TD830" "TD828A")
("TD834" "TD830")
("TD838" "TDMBLA")
("TDR.PBLA" "TD834")
("TD844B.A" "TD844C")
("TD846B" "TD844B.A")))
(defun remove-manual-track-links ()
(loop
for k being the hash-keys of *replaced-track-links-set*
do (setf (gethash k *track-links-set*)
(gethash k *replaced-track-links-set*)))
(clrhash *replaced-track-links-set*))
(defun calculate-exponential-base (max top)
(expt top
(/ 1 max)))
@ -1100,12 +1212,36 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
((> in max) top)
(t (expt base in))))
(defun write-track-links-graphviz (&key (out *standard-output*) (cutoff 5))
(defun dump-track-links-to-file (out)
(with-open-file (stream out
:direction :output
:element-type '(unsigned-byte 8))
(cpk:encode (alexandria:hash-table-alist *track-links-set*)
:stream stream)))
(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)))
(defun dump-normalized-track-links-to-file (out)
(with-open-file (stream out
:direction :output
:element-type '(unsigned-byte 8))
(cpk:encode (alexandria:hash-table-alist *normalized-track-links*)
:stream stream)))
(defun write-track-links-graphviz (&key (out *standard-output*) (cutoff 20))
"Write the track links out in graphviz format."
(princ "digraph {" out)
(format out "node [shape=box margin=\"0.1,0.1\"];
layout = \"neato\";")
(terpri out)
(format *debug-io* "*** Writing track descriptions~%")
(loop
for key in (get-all "D-track-desc-*")
for actual = (subseq key 13)
@ -1116,30 +1252,109 @@ layout = \"neato\";")
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(format *debug-io* "*** Calculating quartiles~%")
(multiple-value-bind (q1 q3) (track-links-quartiles :cutoff cutoff)
(let* ((base (calculate-exponential-base q3 3)))
(let* ((base (calculate-exponential-base q3 3))
(terminators nil)
(sources nil)
(nlinks 0)
(per-dest-links (make-hash-table :test 'equal))
(per-src-links (make-hash-table :test 'equal)))
(format *debug-io* "*** Calculating per-destination links (~A links)~%" (hash-table-size *track-links-set*))
(loop
for (a b) being the hash-keys of *track-links-set*
for (src dest) 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))
unless (or
(string= src dest)
(< v q1))
do (symbol-macrolet
((dest-links (gethash dest per-dest-links)))
(unless dest-links
(setf dest-links nil))
(push (cons src v) dest-links)))
(format *debug-io* "*** Calculating per-source links (~A dests)~%" (hash-table-size per-dest-links))
(loop
for b being the hash-keys of per-dest-links
using (hash-value srcs)
do (let* ((num-manuals (count-if (lambda (srcval)
(eql (cdr srcval)
+manual-count+))
srcs))
(new-len (min (length srcs) (+ 3 num-manuals))))
(setf (gethash b per-dest-links)
(subseq (sort (copy-seq srcs) #'> :key #'cdr) 0 new-len)))
(loop
for (a . v) in (gethash b per-dest-links)
for i from 0
do (symbol-macrolet
((src-links (gethash a per-src-links)))
(unless src-links
(setf src-links nil))
(incf nlinks)
(push (cons b v) src-links))))
(format *debug-io* "*** Calculating sources & terminators~%")
(loop
for b being the hash-keys of per-dest-links
using (hash-value srcs)
do (loop
for (a . v) in srcs
when (null (gethash a per-dest-links))
do (pushnew a sources :test #'string=))
(when (null (gethash b per-src-links))
(pushnew b terminators :test #'string=)))
(format *debug-io* "*** ~A sources / ~A terminators~%" (length sources) (length terminators))
(format *debug-io* "*** Writing ~A links~%" nlinks)
(clrhash *normalized-track-links*)
(loop
for b being the hash-keys of per-dest-links
using (hash-value srcs)
do (loop
for (a . v) in srcs
for i from 0
do (let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2)))
(src-count (length (gethash a per-dest-links)))
(redness 0.0)
(distance (+ (- 3.5 score-2
(if (eql v +manual-count+)
0
(* 0.5 (1- (length srcs))))))))
(when (and (eql src-count 1)
(eql (length srcs) 1))
(setf redness 1.0)
(setf distance 1.5))
(symbol-macrolet
((normalized-links (gethash a *normalized-track-links*)))
(unless normalized-links
(setf normalized-links nil))
(push (list b distance) normalized-links))
(format out "\"~A\" -> \"~A\" [weight=~A len=~F label=\"~A (~A/~A ~A%)\" color=\"0.0 ~F ~F\" fontcolor=\"0.0 ~F ~F\" style=\"~A\"];~%"
a
b
score-perc
distance
v
(1+ i)
(length srcs)
score-perc
redness
(/ (- 100 score-perc) 100)
redness
(+ 0.2 (/ (- 100 score-perc) 120))
(cond
((> score-perc 80) "bold")
((< score-perc 20) "dotted")
(t "solid"))))))
(princ "}" out)
(format t "*** Sources:~%")
(loop
for code in sources
do (format t " ~A: ~A~%" code (red:get (format nil "D-track-desc-~A" code))))
(format t "*** Terminators:~%")
(loop
for code in terminators
do (format t " ~A: ~A~%" code (red:get (format nil "D-track-desc-~A" code))))
"}")))
(defun write-track-links-graphviz-clustered (&optional (out *standard-output*))
"Write the track links out in graphviz format."
@ -1188,7 +1403,8 @@ color=lightblue;
(loop
for train in train-list
do (format t "~&*** Processing train ~A...~%" train)
do (unarchive-trains-tar train #'populate-track-links-set))
do (time (with-simple-restart (next-file "Move on to the next file.")
(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)
@ -1254,3 +1470,58 @@ color=lightblue;
do (%find-rescuable-train start rescuable x)))
(when depth
(values (elt rescuable pos) real-x)))))
(defun get-dijkstra-path (previous-table goal)
(nreverse
(cons goal
(loop
with cur = goal
for value = (gethash cur previous-table)
while value
do (setf cur value)
collect value))))
(defun track-dijkstra (start goal)
"Return the shortest path from START to GOAL, if one exists."
(when (string= start goal)
(return-from track-dijkstra
(values 0.0 (list start goal))))
(let ((distances (make-hash-table :test 'equal))
(previous (make-hash-table :test 'equal))
(queue (make-instance 'cl-heap:priority-queue)))
(setf (gethash start distances) 0.0)
(loop
for v being the hash-keys of *normalized-track-links*
do (unless (string= v start)
;; sad non-portable code :<
(setf (gethash v distances) SB-EXT:DOUBLE-FLOAT-POSITIVE-INFINITY)))
(cl-heap:enqueue queue start 0.0)
(loop
for next = (cl-heap:dequeue queue)
while next
do (loop
for (neighbour link-length) in (gethash next *normalized-track-links*)
do (let ((alt (+ (gethash next distances)
link-length)))
(when (< alt (or (gethash neighbour distances)
sb-ext:double-float-positive-infinity))
(setf (gethash neighbour distances) alt)
(setf (gethash neighbour previous) next)
(when (string= neighbour goal)
(return-from track-dijkstra
(values
alt
(get-dijkstra-path previous goal))))
(cl-heap:enqueue queue neighbour alt)))))
(values
sb-ext:double-float-positive-infinity
(list goal))))
(defun find-rescuable-train-dijkstra (start line-code)
(let ((rescuable (get-rescuable-trains line-code)))
(mapcar
(lambda (train-and-code)
(cons
(car train-and-code)
(multiple-value-list (track-dijkstra start (cdr train-and-code)))))
rescuable)))

164
wobsite.lisp

@ -44,7 +44,12 @@
:class "govuk-header__link govuk-header__link--homepage"
(:span
:class "govuk-header__logotype-text"
"intertube")))))
"intertube")))
(:a
:class "govuk-button govuk-button--secondary"
:|onClick| "window.location.reload()"
:style "margin-bottom: 0; float: right; margin-right: 10px; font-size: 1rem;"
"Reload")))
(:div
:class "govuk-width-container"
(:main
@ -108,18 +113,18 @@
(whole-key (format nil "~A-train-~A" code train-id))
(data (trackernet::redis-last-cpk whole-key)))
(when data
(list data))))
(list (cons whole-key data)))))
active)))
(defun group-trains-by-destination (train-list)
(let ((dests (make-hash-table :test 'equal)))
(loop
for (observer train-obj) in train-list
for (key . (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))))
(push (list key observer train-obj) (gethash dest dests))))
(sort
(alexandria:hash-table-alist dests)
(lambda (a b)
@ -130,16 +135,30 @@
(flexi-streams:string-to-octets
str)))
(defun display-trackernet-train (train)
(defun universal-time-hms (time)
(multiple-value-bind (s m h)
(decode-universal-time time)
(format nil
"~2,'0D:~2,'0D:~2,'0D" h m s)))
(defun display-trackernet-train (train &key code ts reporter)
(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)))
(if ts
(who:htm
(:td
:class "govuk-table__cell ts-field"
(who:esc (universal-time-hms ts))))
(who:htm
(: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"
:class (if ts
"govuk-table__cell no-phones"
"govuk-table__cell")
(let* ((trip-no (trackernet::trip-no train))
(set-no (trackernet::set-no train))
(class (if (string= trip-no "0")
@ -164,10 +183,118 @@
(trackernet::location-desc train)
"<somewhere>"))
(who:str " ")
(when code
(who:htm
(:a
:class "govuk-link"
:href (format nil "/train?train=~A"
code)
"[more]")
(who:str " ")))
(when reporter
(who:htm
(:strong
:class "govuk-tag govuk-tag--yellow train-reporter"
(who:esc reporter))
(who:str " ")))
(:strong
:class "govuk-tag govuk-tag--grey train-track-code"
(who:esc (trackernet::track-code train))))))))
(hunchentoot:define-easy-handler (train :uri "/train") (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 "/train?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))
(train-data (trackernet::redis-cpk-sorted-set-all train))
(*accent-colour* (apply #'html-rgb-colour (third line-data)))
(start-ts (universal-time-hms (first (first train-data))))
(lcids '())
(dests '())
(wtts '()))
(loop
for (ts reporter train) in train-data
do (pushnew (trackernet::set-no train) wtts
:test #'string=)
(when (trackernet::destination-desc train)
(pushnew (trackernet::destination-desc train) dests
:test #'string=))
(pushnew (trackernet::lcid train) lcids
:test #'string=))
(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"
(who:fmt
"Train history for ~A"
train))
(:h1
:class "govuk-heading-xl"
(who:fmt "Train to ~A"
(or
(trackernet::destination-desc
(third (car (last train-data))))
"nowhere")))
(:p
:class "govuk-body-l"
(:strong
(who:fmt "~A" (length train-data)))
" observations for this train; first observed "
(:strong
(who:esc start-ts))
".")
(:p
:class "govuk-body"
(who:fmt "Leading car IDs: ~{~A~^, ~} &middot; WTT IDs: ~{~A~^, ~} &middot; Destinations: ~{~A~^, ~}"
lcids wtts dests))
(:table
:class "govuk-table"
(:thead
:class "govuk-table__head"
(:tr
:class "govuk-table__row"
(:th
:class "govuk-table__header"
"Time")
(:th
:class "govuk-table__header no-phones"
(: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"
"Location")))
(:tbody
:class "govuk-table__body"
(loop
with last = nil
for (ts reporter train) in (sort train-data #'>
:key (lambda (trn)
(first trn)))
unless (equal last (trackernet::track-code train))
do (who:str (display-trackernet-train train
:ts ts
:reporter reporter))
(setf last (trackernet::track-code train))))))))
(hunchentoot:define-easy-handler (line :uri "/line") (code)
(let ((line-data (tube-line-by-code code)))
(unless line-data
@ -284,6 +411,9 @@
(:h2
:class "govuk-heading-l"
:id (string-base64 group)
(:span
:class "train-to"
"to ")
(who:esc group))
(:table
:class "tube-line-list govuk-table"
@ -312,10 +442,10 @@
(: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)))))))))))
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)))))))))))
(hunchentoot:define-easy-handler (root :uri "/") ()
(render ()
@ -379,4 +509,10 @@
hunchentoot:*dispatch-table*)
(defun start-webserver ()
(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 5000)))
(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 4000)))
(defun main ()
(let ((*package* (find-package 'intertube-web)))
(redis:connect)
(start-webserver)
(sb-impl::toplevel-repl nil)))
Loading…
Cancel
Save