Compare commits

...

4 Commits

  1. 2
      aa-dist.js
  2. 55
      autocomplete.js
  3. 3
      deploy.sh
  4. 3
      deploy.txt
  5. 20
      govuk.css
  6. 1125
      trackernet.lisp
  7. 438
      wobsite.lisp

2
aa-dist.js

File diff suppressed because one or more lines are too long

55
autocomplete.js

@ -0,0 +1,55 @@
function suggest(query, populateResults) {
fetch("/tracksuggestions?code=" + window.linecode + "&query=" + encodeURIComponent(query))
.then(function(resp) { return resp.json(); })
.then(function(data) {
populateResults(data);
})
.catch(function(err) {
console.error("Request failed: " + err);
});
}
function inputTemplate(result) {
if (result) {
return result.code;
}
return undefined;
}
function suggestionTemplate(result) {
if (result) {
return "<span class=\"track-suggestion\">" + result.name + " <strong class=\"govuk-tag govuk-tag--grey train-track-code\">" + result.code + "</strong></span>";
}
return undefined;
}
function confirmCallback(ret) {
setTimeout(function() {
document.querySelector("#line-search-form").submit();
}, 1);
}
window.onload = function() {
var linecode = document.querySelector("#linecode");
window.linecode = linecode.value;
var input = document.querySelector("#trackcode");
var value = input.value ? input.value : "";
var auto = document.querySelector("#trackcode-autocomplete-container");
auto.innerHTML = "";
accessibleAutocomplete({
element: auto,
id: 'trackcode',
name: 'trackcode',
required: false,
defaultValue: value,
minLength: 3,
autoselect: true,
confirmOnBlur: false,
onConfirm: confirmCallback,
templates: {
suggestion: suggestionTemplate,
inputValue: inputTemplate,
},
tNoResults: function() {
return "No stations found";
},
source: suggest
});
};

3
deploy.sh

@ -1,3 +1,2 @@
#!/bin/sh
echo '*** NB: press Enter after the text stops scrolling past!'
sbcl < deploy.txt
sbcl --noinform --load deploy.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 cl-heap))
(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*))
(sb-ext:save-lisp-and-die "./intertube-scraper" :toplevel #'trackernet::main :executable t)

20
govuk.css

File diff suppressed because one or more lines are too long

1125
trackernet.lisp

File diff suppressed because it is too large

438
wobsite.lisp

@ -7,6 +7,7 @@
(defparameter *title* "intertube")
(defvar *accent-colour* "#1d70b8")
(defparameter *site-css* #.(uiop:read-file-string "./govuk.css"))
(defun with-rendering-context (func)
(who:with-html-output-to-string (*standard-output* nil
@ -21,9 +22,8 @@
(:meta
:name "viewport"
:content "width=device-width, initial-scale=1, viewport-fit=cover")
(:link
:href "/styles.css"
:rel "stylesheet"))
(:style
(who:str *site-css*)))
(:body
:class "govuk-template__body"
(:a
@ -46,9 +46,8 @@
:class "govuk-header__logotype-text"
"intertube")))
(:a
:class "govuk-button govuk-button--secondary"
:class "govuk-button govuk-button--secondary reload-button"
:|onClick| "window.location.reload()"
:style "margin-bottom: 0; float: right; margin-right: 10px; font-size: 1rem;"
"Reload")))
(:div
:class "govuk-width-container"
@ -68,7 +67,31 @@
:class "govuk-footer__meta-item govuk-footer__meta-item--grow"
(:span
:class "govuk-footer__licence-description"
"This webpage may contain wiggly donkers.")))))))))
"Powered by "
(:a
:class "govuk-footer__link"
:href "https://tfl.gov.uk/info-for/open-data-users/"
"open data from Transport for London")
"; track layout information generated internally. "
"Site design using the "
(:a
:class "govuk-footer__link"
:href "https://github.com/alphagov/govuk-frontend"
"GOV.UK Design System")
", under the terms of the "
(:a
:class "govuk-footer__link"
:href "https://github.com/alphagov/govuk-frontend/blob/master/LICENSE.txt"
"MIT License")
". "
"Please don't scrape or re-use information provided here "
"without express consent. All rights reserved."
(:span
:style "float: right;"
(:a
:class "govuk-footer__link"
:href "https://theta.eu.org/"
"an eta project")))))))))))
(defmacro render (() &body body)
`(with-rendering-context
@ -106,6 +129,11 @@
<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\" />
</svg>")
(defun train-objects-on-line (code)
(let ((active (trackernet::trains-active-on-line code)))
(mapcan (lambda (active-key)
@ -136,25 +164,92 @@
str)))
(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)))
(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:~2,'0D" h m s)))
(defun mini-graphviz-stream (around-codes)
(let* ((proc
(uiop:launch-program
'("dot" "-Tpng")
:input :stream
:output :stream
:element-type '(unsigned-byte 8)))
(viz-in
(flexi-streams:make-flexi-stream
(uiop:process-info-input proc)
:external-format :utf-8)))
(unwind-protect
(trackernet::write-mini-graphviz around-codes :out viz-in)
(close viz-in))
(uiop:process-info-output proc)))
(defparameter *hmac-key* (crypto:random-data 32))
(defun hmac-sha256 (key data)
"Computes the HMAC-SHA256 message authentication code for DATA, using the secret KEY."
(let ((mac (crypto:make-mac :hmac key :sha256)))
(crypto:update-mac mac data)
(crypto:produce-mac mac)))
(defun trusted-serialize (data)
"Given some DATA, serializes it into CONSPACK-encoded base64 and returns the data, plus an HMAC used to authenticate the data."
(let* ((cpk-data (cpk:encode data))
(hmac (hmac-sha256 *hmac-key* cpk-data)))
(values
(qbase64:encode-bytes cpk-data)
(qbase64:encode-bytes hmac))))
(defun trusted-deserialize (data hmac)
"Given two base64-encoded DATA and HMAC strings, deserializes and returns the data iff the HMAC validates. If it does not validate, returns NIL."
(let* ((undata (subseq (qbase64:decode-string data) 0))
(unhmac (qbase64:decode-string hmac))
(should-be (hmac-sha256 *hmac-key* undata)))
(when (equalp should-be unhmac)
(cpk:decode undata))))
(defun display-trackernet-train (train &key code ts reporter)
(hunchentoot:define-easy-handler (miniviz :uri "/miniviz") (around hmac)
(unless (and around hmac)
(setf (hunchentoot:return-code*) 400)
(hunchentoot:abort-request-handler "need some params please"))
(let* ((actual-around (ignore-errors (trusted-deserialize around hmac))))
(unless actual-around
(setf (hunchentoot:return-code*) 401)
(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)))
(unwind-protect
(loop
for byte = (read-byte in nil nil)
while byte
do (write-byte byte out))
(close in)))))
(defun display-trackernet-train (train &key code ts reporter distance show-dest maybe-hide-codes)
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
(:tr
:class "train-desc govuk-table__row"
(if ts
(cond
(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)))))
(who:esc (universal-time-hms ts)))))
(distance
(who:htm
(:td
:class "govuk-table__cell distance-field id-field no-phones"
(who:fmt "~,2F" distance))))
(t
(who:htm
(:td ; Train ID
:class "govuk-table__cell id-field no-phones"
(who:esc (trackernet::train-id train))))))
(:td ; Set/trip number
:class (if ts
"govuk-table__cell no-phones"
@ -176,13 +271,26 @@
:class "govuk-table__cell id-field no-phones"
(unless (string= (trackernet::lcid train) "0")
(who:esc (trackernet::lcid train))))
(:td ; Destination
(:td ; Location / destination
:class "govuk-table__cell govuk-!-width-two-thirds"
(:span
(who:esc (or
(cdr (assoc (trackernet::track-code train)
(cached-track-suggestions "D")
:test #'string=))
(trackernet::location-desc train)
"<somewhere>"))
(who:str " ")
(when show-dest
(who:htm
(:span
:style "color: darkgray;"
(who:str *govuk-go-arrow-small-svg*)
" "
(who:esc (or
(trackernet::destination-desc train)
"<somewhere>")))
(who:str " ")))
(when code
(who:htm
(:a
@ -194,14 +302,37 @@
(when reporter
(who:htm
(:strong
:class "govuk-tag govuk-tag--yellow train-reporter"
:class "govuk-tag govuk-tag--yellow train-reporter no-phones"
:style "float: right; margin-left: 10px;"
(who:esc reporter))
(who:str " ")))
(:strong
:class "govuk-tag govuk-tag--grey train-track-code"
(when (and code
(< (trackernet::redis-last-score code)
(- (get-universal-time) 30)))
(who:htm
(:strong
:class "govuk-tag govuk-tag--red train-stale"
"Stale")))
(:a
:href (multiple-value-bind (around hmac)
(trusted-serialize (list (trackernet::track-code train)))
(format nil "/miniviz?around=~A&hmac=~A"
(hunchentoot:url-encode
around)
(hunchentoot:url-encode
hmac)))
:class (if maybe-hide-codes
"govuk-tag govuk-tag--grey train-track-code no-phones"
"govuk-tag govuk-tag--grey train-track-code")
(who:esc (trackernet::track-code train))))))))
(hunchentoot:define-easy-handler (train :uri "/train") (train)
(defparameter *max-train-lines* 100)
(hunchentoot:define-easy-handler (train :uri "/train") (train limit)
(when limit
(unless (setf limit (ignore-errors (parse-integer limit)))
(setf (hunchentoot:return-code*) 400)
(hunchentoot:abort-request-handler "bad limit mate")))
(when (< (length train) #.(length "X-train-Y"))
(setf (hunchentoot:return-code*) 400)
(hunchentoot:abort-request-handler
@ -215,11 +346,22 @@
(let* ((line-code (subseq train 0 1))
(line-data (tube-line-by-code line-code))
(train-data (trackernet::redis-cpk-sorted-set-all train))
(train-data-len (length train-data))
(*accent-colour* (apply #'html-rgb-colour (third line-data)))
(start-ts (universal-time-hms (first (first train-data))))
(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))))
(max-to-show (min train-data-len
(or limit *max-train-lines*)))
(lcids '())
(dests '())
(wtts '()))
(setf train-data
(sort train-data #'>
:key (lambda (trn)
(first trn))))
(loop
for (ts reporter train) in train-data
do (pushnew (trackernet::set-no train) wtts
@ -243,23 +385,66 @@
train))
(:h1
:class "govuk-heading-xl"
(who:fmt "Train to ~A"
(who:fmt "Train to ~A "
(or
(trackernet::destination-desc
(third (car (last train-data))))
last-train-obj)
"nowhere")))
(:p
:class "govuk-body-l"
(cond
((> secs-old 90)
(who:htm
(:strong
:class "govuk-tag govuk-tag--red"
(who:fmt "Very Stale"))))
((> secs-old 30)
(who:htm
(:strong
:class "govuk-tag govuk-tag--red"
(who:fmt "Stale"))))
((> secs-old 15)
(who:htm
(:strong
:class "govuk-tag govuk-tag--orange"
"Intermittent")))
(t
(who:htm
(:strong
:class "govuk-tag govuk-tag--turquoise"
"Active"))))
" Showing "
(:strong
(who:fmt "~A" (length train-data)))
(who:fmt "~A" max-to-show))
" of "
(:strong
(who:fmt "~A" train-data-len))
" observations for this train; first observed "
(:strong
(who:esc start-ts))
".")
(:details
:class "govuk-details"
(:summary
:class "govuk-details__summary"
(:span
:class "govuk-details__summary-text"
"Track code graph"))
(:div
:class "govuk-details__text"
(: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"
(who:fmt "Leading car IDs: ~{~A~^, ~} &middot; WTT IDs: ~{~A~^, ~} &middot; Destinations: ~{~A~^, ~}"
lcids wtts dests))
(nreverse lcids)
(nreverse wtts)
(nreverse dests)))
(:table
:class "govuk-table"
(:thead
@ -286,14 +471,157 @@
: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))
with last-dest = nil
for (ts reporter train) in train-data
for i from 0
unless (or
(equal last (trackernet::track-code train))
(>= i max-to-show))
do (who:str (display-trackernet-train train
:ts ts
:show-dest (not (string= (trackernet::destination-desc train) last-dest))
:reporter reporter))
(setf last (trackernet::track-code train))))))))
(setf last-dest (trackernet::destination-desc train))
(setf last (trackernet::track-code train))))
(unless (>= max-to-show train-data-len)
(who:htm
(:p
:class "govuk-body"
(:a
:class "govuk-link"
:href (format nil "/train?train=~A&limit=~A"
train (+ max-to-show 500))
"Show up to 500 more observations"))))))))
(defparameter *autocomplete-js*
#.(concatenate 'string
(uiop:read-file-string "./aa-dist.js")
(uiop:read-file-string "./autocomplete.js")))
(defvar *track-suggestions-cache* (make-hash-table :test 'equal))
(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))
(distanced-objects
(mapcar
(lambda (tlist)
(list
(trackernet::track-dijkstra
(trackernet::track-code (third tlist))
trackcode)
(first tlist)
(third tlist)))
objects)))
(delete-if (lambda (lst)
(eql (car lst) sb-ext:double-float-positive-infinity))
(sort distanced-objects #'< :key #'car))))
(defun cached-track-suggestions (code)
(symbol-macrolet
((cached-result (gethash code *track-suggestions-cache*)))
(if cached-result
cached-result
(setf cached-result (trackernet::line-track-descriptions code)))))
(hunchentoot:define-easy-handler (track-suggestions :uri "/tracksuggestions") (code query)
(unless (tube-line-by-code code)
(setf (hunchentoot:return-code*) 400)
(hunchentoot:abort-request-handler "bad line lol"))
(let* ((suggestions (cached-track-suggestions code))
(names (mapcar #'cdr suggestions))
(prefixed (format nil "at ~A" query))
(matches (fuzzy-match:fuzzy-match prefixed suggestions
:suggestions-display names)))
(setf (hunchentoot:content-type*) "application/json")
(cl-json:encode-json-to-string
(mapcar
(lambda (match)
(let ((name (if (uiop:string-prefix-p "At " (cdr match))
(subseq (cdr match) 3)
(cdr match))))
`((:name . ,name)
(:code . ,(car match)))))
(delete-if (lambda (match) (string= (cdr match) "At Platform"))
matches)))))
(defun now-london-time-str ()
(local-time:format-timestring
nil
(local-time:now)
:format
'((:year 4) #\- (:month 2) #\- (:day 2) #\Space
(:hour 2) #\: (:min 2) #\: (:sec 2))
:timezone
trackernet::+europe-london-tz+))
(hunchentoot:define-easy-handler (line-search :uri "/line-search") (linecode trackcode)
(let ((line-data (tube-line-by-code linecode)))
(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)))
(train-list (trains-by-dijkstra-from linecode trackcode))
(descr (cdr (assoc trackcode (cached-track-suggestions linecode)
:test #'string=)))
(at-descr (if (uiop:string-prefix-p "At" descr)
(subseq descr 3)
descr)))
(render ()
(:a
:class "govuk-back-link"
:href (format nil "/line?code=~A"
linecode)
(who:fmt "~A line"
(first line-data)))
(:span
:class "govuk-caption-xl"
"Train search")
(:h1
:class "govuk-heading-xl"
(who:esc at-descr))
(:p
:class "govuk-body-l"
(:strong
(who:str (length train-list)))
" trains on the line as of "
(:span
:class "id-field"
(who:esc (now-london-time-str))
"."))
(: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 "Distance in arbitrary units from the search term"
"Dist"))
(: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 (distance key train) in train-list
do (who:str (display-trackernet-train train
:distance distance
:maybe-hide-codes t
:show-dest t
:code key)))))))))
(hunchentoot:define-easy-handler (line :uri "/line") (code)
(let ((line-data (tube-line-by-code code)))
@ -322,14 +650,42 @@
" 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)))))
(who:esc (now-london-time-str)))
".")
(:form
:action "/line-search"
:method "get"
:id "line-search-form"
(:script
:type "text/javascript"
(who:str *autocomplete-js*))
(:input
:name "linecode"
:id "linecode"
:type "hidden"
:value code)
(:div
:class "govuk-form-group"
(:h2
:class "govuk-label-wrapper"
(:label
:class "govuk-label govuk-label--l"
:for "trackcode"
"Search for a station"))
(:div
:id "trackcode-hint"
:class "govuk-hint"
"Start typing the name of a station to show a list of options.")
(:div
:id "trackcode-autocomplete-container"
(:input
:class "govuk-input"
:id "trackcode"
:name "trackcode"
:type "text"))))
(:h2
:class "govuk-heading-l"
"Search by destination")
(:p
:class "govuk-body"
"Jump to: "
@ -508,6 +864,12 @@
(push (hunchentoot:create-folder-dispatcher-and-handler "/fonts/" "./fonts/")
hunchentoot:*dispatch-table*)
(defparameter *redis-port* 6379)
(defmethod hunchentoot:acceptor-dispatch-request :around (acceptor request)
(redis:with-connection (:port *redis-port*)
(call-next-method acceptor request)))
(defun start-webserver ()
(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 4000)))

Loading…
Cancel
Save