Browse Source

allow interposes into berths to rescue XR trains

master
eta 1 week ago
parent
commit
8d5f99f222
  1. 35
      trackernet.lisp

35
trackernet.lisp

@ -869,10 +869,10 @@ @@ -869,10 +869,10 @@
;; (see the note inside GET-RESCUABLE-TRAINS for more)
(red:setex (format nil "~A-rescue-~A"
line-code tid)
(+ *train-active-expiry-secs*
*rescue-grace-period-secs*
(if (string= line-code "X")
*xr-train-expiry-secs*
(if (string= line-code "X")
30
(+ *train-active-expiry-secs*
*rescue-grace-period-secs*
*train-active-expiry-secs-real*))
track-code))
;; mark this train as active
@ -924,6 +924,7 @@ @@ -924,6 +924,7 @@
"Returns a list of all trains that were last updated more than *TRAIN-ACTIVE-EXPIRY-SECS* ago, or were created more than *MAX-TRAIN-AGE-SECS* ago."
(let* ((trains (get-all "?-train-*"))
(age-cutoff (- (get-universal-time) *max-train-age-secs*))
(xr-cutoff (- (get-universal-time) 3))
(cutoff (- (get-universal-time) *train-active-expiry-secs*)))
(delete-if-not (lambda (train)
(if (string= "X" (subseq train 0 1))
@ -931,7 +932,12 @@ @@ -931,7 +932,12 @@
;; or the train being marked as deleted
(or
(< (redis-first-score train) age-cutoff)
(uiop:string-prefix-p "X-DEL" (car (redis-last-cpk train))))
(and
(uiop:string-prefix-p "X-DEL" (car (redis-last-cpk train)))
;; don't *immediately* delete trains marked
;; as deleted; wait 3 seconds (see above) for
;; something to be interposed there
(< (redis-last-score train) xr-cutoff)))
(or
(< (redis-first-score train) age-cutoff)
(< (redis-last-score train) cutoff))))
@ -4454,6 +4460,9 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping. @@ -4454,6 +4460,9 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping.
(fake-train (cadr data)))
(unless (string= (car data) "X-DEL") ; already done
(log:info "Deleting train with headcode ~A" headcode)
(red:setex (format nil "berth-last:Q0:~A" (track-code fake-train))
30
(subseq train #.(length "X-train-")))
(redis-train (+ ts 1) "X" "X-DEL" fake-train)))))
(defun stomp-td-message-handler (message-type body)
@ -4472,7 +4481,7 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping. @@ -4472,7 +4481,7 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping.
(format nil "berth:Q0:~A" old-berth))))
(when (and old-headcode (eql message-type :+CB-MSG+))
(statsd-inc "intertube.xr-berth-cancel")
(log:warn "in berth ~A, ~A cancelled" old-berth old-headcode)
(log:info "in berth ~A, ~A cancelled" old-berth old-headcode)
(enqueue-td-deletion old-headcode)))))
;; this is so ridiculously stupid and yet also excellent
(when (member message-type '(:+CA-MSG+ :+CC-MSG+))
@ -4489,6 +4498,9 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping. @@ -4489,6 +4498,9 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping.
(old-headcode
(red:getset (format nil "berth:Q0:~A" berth)
headcode))
(last-headcode
(red:get (format nil "berth-last:Q0:~A" berth)))
(rescue-headcode (or old-headcode last-headcode))
(last-entry (redis-last-cpk (format nil "X-train-~A" headcode)))
(ts (+ (/ (parse-integer (cdr (assoc :time body))) 1000)
2208988800))
@ -4535,7 +4547,16 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping. @@ -4535,7 +4547,16 @@ Return four values: a set of nodes, edges, weights, and a new->old edge mapping.
(redis-train ts "X" (if (eql message-type :+CA-MSG+)
"X-XCA"
"X-XCC")
fake-train))))
fake-train)
(when (and
(eql message-type :+CC-MSG+)
rescue-headcode
(red:exists (format nil "X-train-~A" rescue-headcode)))
(statsd-inc "intertube.xr-rescue")
(log:info "interpose in berth ~A links ~A to ~A, rescuing"
berth rescue-headcode headcode)
(rescue-train (format nil "X-train-~A" rescue-headcode)
(format nil "X-train-~A" headcode))))))
(defvar *current-stomp-td-backoff* 1)

Loading…
Cancel
Save