Browse Source

tweak rescue / archival behaviour massively, add stale tags

master
eta 2 months ago
parent
commit
53434c458c
  1. 121
      trackernet.lisp
  2. 71
      wobsite.lisp

121
trackernet.lisp

@ -403,8 +403,9 @@
(defparameter *trackernet-scrape-interval* 2.5)
(defparameter *trackernet-kill-switch* nil)
(defparameter *prediction-expiry-secs* 60)
(defparameter *train-active-expiry-secs* 300)
(defparameter *train-active-expiry-secs* 60)
(defparameter *train-set-code-expiry-secs* 360)
(defparameter *track-code-expiry-secs* 10)
(defparameter *rude-requests-per-minute* 300)
(defun make-trackernet-filename (pred)
@ -426,21 +427,17 @@
(defun redis-train (universal-ts line-code code-station train)
(with-slots (train-id set-no trip-no lcid seconds-to track-code location-desc leading-car-no) train
(when (and (or lcid train-id) seconds-to track-code)
(let ((tid (or (if (and lcid (string= lcid "0"))
nil
lcid)
(if (and set-no (string= set-no "000"))
nil
(format nil "set~A-t~A" set-no trip-no))
(format nil "tid~A" train-id))))
(when (and train-id seconds-to track-code)
(let ((tid (format nil "tid~A" train-id)))
;; get a mapping of seconds to -> track code
(red:zadd (format nil "~A-secs-to-track-code"
code-station)
seconds-to
track-code)
;; get a mapping of track code -> description
(when location-desc
(when (and location-desc
;; this is highly annoying
(not (string= location-desc "At Platform")))
(red:set (format nil "~A-track-desc-~A"
line-code track-code)
location-desc))
@ -458,42 +455,45 @@
tid
cl-ansi-text:+reset-color-string+
train)
(statsd-inc "intertube.new")
;; make a rescuable thingy
(red:setex (format nil "~A-rescue-~A"
line-code tid)
*train-active-expiry-secs*
(* 5 *train-active-expiry-secs*)
track-code))
;; mark this train as active
(red:setex (format nil "~A-active-~A"
line-code tid)
*train-active-expiry-secs*
"yep")
(unless (or (not leading-car-no) (string= leading-car-no "0")
(uiop:string-prefix-p "set" tid))
;; check whether the train's leading car no was previously
;; used by a train with a different id
(let ((lcn-train-id
(red:get
(format nil "~A-lcn-~A"
line-code leading-car-no))))
(when (and lcn-train-id
(not (string= lcn-train-id
tid)))
;; if so, it might be the same train
(format
*error-output*
"scraper(~A): ~Aleading car no ~A changed~A: ~A -> ~A~%"
code-station
(cl-ansi-text:make-color-string :yellow :style :background)
leading-car-no
cl-ansi-text:+reset-color-string+
lcn-train-id
tid)
(statsd-inc "intertube.leading-car-no-change")))
;; reserve the leading car no
(red:setex (format nil "~A-lcn-~A"
line-code leading-car-no)
*train-set-code-expiry-secs*
;; check whether the train's track code was previously
;; used by a train with a different id
(let ((cc-train-id
(red:get
(format nil "~A-curcode-~A"
line-code track-code))))
(when (and cc-train-id
(not (string= cc-train-id
tid)))
;; if so, it might be the same train
(format
nil
"scraper(~A): ~Atrack code ~A double occupied~A: ~A (~A recs) -> ~A (~A recs)~%"
code-station
(cl-ansi-text:make-color-string :yellow :style :background)
track-code
cl-ansi-text:+reset-color-string+
cc-train-id
(length (redis-cpk-sorted-set-all (format nil "~A-train-~A"
line-code cc-train-id)))
tid
(length (redis-cpk-sorted-set-all (format nil "~A-train-~A"
line-code tid))))
(statsd-inc "intertube.curcode-change"))
;; reserve the track code
(red:setex (format nil "~A-curcode-~A"
line-code track-code)
*track-code-expiry-secs*
tid))
(unless (or (string= set-no "000")
(uiop:string-prefix-p "set" tid))
@ -508,7 +508,7 @@
tid)))
;; if so, it might be the same train
(format
*error-output*
nil
"scraper(~A): ~Aset code ~A (~A) changed~A: ~A -> ~A~%"
code-station
(cl-ansi-text:make-color-string :magenta :style :background)
@ -701,35 +701,36 @@
(third (car (last (car (last train))))))
(*print-right-margin* nil))
(format
t
"~&archiver: ~Aarchiving ~A (~A recs)~A: ~A~%"
(cl-ansi-text:make-color-string :red :style :background)
nil
"~&archiver: maybe archiving ~A (~A recs): ~A~%"
(second train)
(length (car (last train)))
cl-ansi-text:+reset-color-string+
last-data)
(block continue
(loop
with new-score
for (new-code distance code-path)
in (sort (find-rescuable-train-dijkstra (track-code last-data) (subseq (second train) 0 1)) #'< :key #'cadr)
do (setf new-score (or (redis-first-score new-code) 0))
do (format
t
nil
"~&archiver: could rescue with: ~a @ ~a: ~A steps, ~A secs~%"
new-code
distance
(length code-path)
(- (redis-first-score new-code)
(- new-score
(first train)))
unless (or
(< (- (redis-first-score new-code)
(< (- new-score
(first train))
0)
(string= new-code (second train))
(> distance *rescue-max-dist*))
do (format
t
"~&archiver: ~adoing rescue with~a: ~a @ ~a: ~{~a~^ -> ~}~%"
"~&archiver: ~arescuing ~A with~a: ~a @ ~a: ~{~a~^ -> ~}~%"
(cl-ansi-text:make-color-string :cyan :style :background)
(second train)
cl-ansi-text:+reset-color-string+
new-code
distance
@ -738,15 +739,30 @@
(red:incr (format nil "~A-code-rescues-~A"
(subseq (second train) 0 1)
(track-code last-data)))
(red:del (second train))
(return-from continue))
(when (> (first train) (- (get-universal-time)
(* 5 *train-active-expiry-secs*)))
(return-from continue))
(format
t
"~&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)
(red:incr (format nil "~A-code-archives-~A"
(subseq (second train) 0 1)
(track-code last-data)))
(statsd-inc "intertube.archived")
(conspack-encode-to-archive tar
(format nil "~A-~A.trn"
(first train)
(second train))
train)))))))
train)
(red:del (second train))))))))
(defun archive-entry-filename (entry)
(cond
@ -941,17 +957,18 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Archive all trains that have expired."
(let ((trains (get-archivable-trains)))
(unless (null trains)
(format t "~&archiver: ~A archivable trains~%"
(length 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)
(statsd-gauge "intertube.maybe-archivable" (length trains))
(handler-case
(progn
(archive-trains-tar trains)
(statsd-counter "intertube.archived" (length trains))
(mapc #'red:del trains))
(archive-trains-tar trains))
;; (statsd-counter "intertube.archived" (length trains))
;; (mapc #'red:del trains))
(error (e)
(format *error-output* "~&archiver: failed: ~A~%" e))))))

71
wobsite.lisp

@ -67,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
@ -263,6 +287,13 @@
:class "govuk-tag govuk-tag--yellow train-reporter"
(who:esc reporter))
(who:str " ")))
(when (and code
(< (trackernet::redis-last-score code)
(- (get-universal-time) 30)))
(who:htm
(:strong
:class "govuk-tag govuk-tag--red train-stale"
"Stale")))
(:strong
:class "govuk-tag govuk-tag--grey train-track-code"
(who:esc (trackernet::track-code train))))))))
@ -292,12 +323,17 @@
(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
@ -321,14 +357,35 @@
train))
(:h1
:class "govuk-heading-xl"
(who:fmt "Train to ~A"
(who:fmt "Train to ~A "
(or
(trackernet::destination-desc
last-train-obj)
"nowhere")))
(:p
:class "govuk-body-l"
"Showing "
(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" max-to-show))
" of "
@ -357,7 +414,9 @@
(: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
@ -384,9 +443,7 @@
:class "govuk-table__body"
(loop
with last = nil
for (ts reporter train) in (sort train-data #'>
:key (lambda (trn)
(first trn)))
for (ts reporter train) in train-data
for i from 0
unless (or
(equal last (trackernet::track-code train))

Loading…
Cancel
Save