Browse Source

autocomplete, mini graphviz, redising each connection

master
eta 2 months ago
parent
commit
a199e82ca5
  1. 2
      aa-dist.js
  2. 55
      autocomplete.js
  3. 20
      govuk.css
  4. 69
      trackernet.lisp
  5. 333
      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
});
};

20
govuk.css

File diff suppressed because one or more lines are too long

69
trackernet.lisp

@ -1132,7 +1132,7 @@ 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-Y"))
(cons (subseq key #.(length "X-track-desc-"))
(red:get key)))
(get-all (format nil "~A-track-desc-*"
line-code))))
@ -1247,6 +1247,73 @@ 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))
"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=)
(pushnew (car dest) nodes
: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)))
(defun write-track-links-graphviz (&key (out *standard-output*) (cutoff 20))
"Write the track links out in graphviz format."
(princ "digraph {" out)

333
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"
@ -78,7 +77,7 @@
,@body))))
(hunchentoot:define-easy-handler (css :uri "/styles.css") ()
(hunchentoot:handle-static-file "~/common-lisp/intertube/govuk.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))
@ -143,20 +142,85 @@
(format nil
"~2,'0D:~2,'0D:~2,'0D" h m s)))
(defun display-trackernet-train (train &key code ts reporter)
(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))))
(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)
(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"
@ -203,7 +267,13 @@
:class "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
@ -217,8 +287,14 @@
(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))
(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 '()))
@ -248,16 +324,36 @@
(who:fmt "Train to ~A"
(or
(trackernet::destination-desc
(third (car (last train-data))))
last-train-obj)
"nowhere")))
(:p
:class "govuk-body-l"
"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~^, ~}"
@ -291,11 +387,150 @@
for (ts reporter train) in (sort train-data #'>
:key (lambda (trn)
(first trn)))
unless (equal last (trackernet::track-code train))
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
:reporter reporter))
(setf last (trackernet::track-code 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)))))
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
:code key)))))))))
(hunchentoot:define-easy-handler (line :uri "/line") (code)
(let ((line-data (tube-line-by-code code)))
@ -324,33 +559,39 @@
" 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))
:timezone
trackernet::+europe-london-tz+)))
(who:esc (now-london-time-str)))
".")
(: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, platform, or track code.")
(:form
:action "/line-search"
:method "get"
:id "line-search-form"
(:script
:type "text/javascript"
(who:str *autocomplete-js*))
(:input
:class "govuk-input"
:id "trackcode"
:name "trackcode"
:type "text"))
: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, platform, or track code.")
(:div
:id "trackcode-autocomplete-container"
(:input
:class "govuk-input"
:id "trackcode"
:name "trackcode"
:type "text"))))
(:h2
:class "govuk-heading-l"
"Search by destination")
@ -532,6 +773,12 @@
(push (hunchentoot:create-folder-dispatcher-and-handler "/fonts/" "./fonts/")
hunchentoot:*dispatch-table*)
(defparameter *redis-port* 3000)
(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