fix stupid archiving / rescue behaviours, use log4cl, reorg code

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
+	  });
+};
+

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

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) 
 

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