Skip to content
GitLab
Explore
Sign in
Commits on Source (5)
make it more quartiled
· 22ef219a
eta
authored
Mar 16, 2021
22ef219a
configurable cutoffs, gitignore
· 7cef885a
eta
authored
Mar 16, 2021
7cef885a
experimental rescue support
· 1d3dbabf
eta
authored
Mar 17, 2021
1d3dbabf
make statsd less crashy
· 8503ee36
eta
authored
Mar 20, 2021
8503ee36
wobsite!
· 7302b882
eta
authored
Mar 20, 2021
7302b882
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.
Click to expand it.
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-quartile
s
(
&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-quartile
s
: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
" · "
)))
(
: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
)))