allow interposes into berths to rescue XR trains

trackernet.lisp

@@ -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 @@
   "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 @@
                          ;; 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.
            (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.
                            (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.
            (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.
       (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)