Browse Source

experimental rescue support

master
eta 3 months ago
parent
commit
1d3dbabfdd
  1. 86
      trackernet.lisp

86
trackernet.lisp

@ -438,7 +438,12 @@
(cl-ansi-text:make-color-string :green :style :background)
tid
cl-ansi-text:+reset-color-string+
train))
train)
;; make a rescuable thingy
(red:setex (format nil "~A-rescue-~A"
line-code tid)
*train-active-expiry-secs*
track-code))
;; mark this train as active
(red:setex (format nil "~A-active-~A"
line-code tid)
@ -625,6 +630,8 @@
"~&archiver: failed to pigz last archive: code ~A~%"
exit-code))))))
(defparameter *rescue-depth* 3)
(defun archive-trains-tar (keys)
"Archive trains from KEYS, a list of Redis train sorted set keys."
(maybe-pigz-last-archive)
@ -651,7 +658,17 @@
(cl-ansi-text:make-color-string :red :style :background)
(second train)
cl-ansi-text:+reset-color-string+
last-data))
last-data)
(multiple-value-bind (rescue depth)
(find-rescuable-train (track-code last-data) (subseq (second train) 0 1) *rescue-depth*)
(when rescue
(format
t
"~&archiver: ~Acould rescue with~A: ~A (depth ~A)~%"
(cl-ansi-text:make-color-string :cyan :style :background)
cl-ansi-text:+reset-color-string+
rescue
depth))))
do (conspack-encode-to-archive tar
(format nil "~A-~A.trn"
(first train)
@ -868,6 +885,8 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(length codes))))
(when (> rpm *rude-requests-per-minute*)
(error "~A requests/min is a bit rude" rpm))
(format t "~&~A nodes in rescue table~%"
(hash-table-size *track-rescue-graph*))
(format t "~&starting ~A scrapers, ~A requests/min...~%"
(length codes) rpm))
(setf *trackernet-kill-switch* nil)
@ -1111,7 +1130,7 @@ layout = \"neato\";")
(let ((descs-ht (make-hash-table :test 'equal)))
(loop
for key in (get-all "D-track-desc-*")
for actual = (subseq key 13)
for actual = (subseq key #.(length "D-track-desc-"))
for value = (red:get key)
do (when (and
(> (length value) 0)
@ -1154,4 +1173,63 @@ color=lightblue;
(defun write-track-links-graphviz-to-file (outfile)
(with-open-file (out outfile
:direction :output)
(write-track-links-graphviz out)))
(write-track-links-graphviz :out out)))
(defparameter *track-rescue-graph*
(or
(ignore-errors
(alexandria:alist-hash-table (uiop:read-file-form "./rescue-table.dat")
:test 'equal))
(make-hash-table :test 'equal)))
(defun make-rescue-graph ()
(setf *track-rescue-graph* (make-hash-table :test 'equal))
(multiple-value-bind (q1 q3) (track-links-quartiles :cutoff 5)
(let* ((base (calculate-exponential-base q3 3)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
do (symbol-macrolet ((rescue-val (gethash a *track-rescue-graph*)))
(let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2))))
(when (and
(not (string= b a))
(> v q1)
(>= score-perc 20))
(unless rescue-val
(setf rescue-val nil))
(pushnew b rescue-val))))))))
(defun get-rescuable-trains (line-code)
(mapcar
(lambda (x)
(cons
(format nil "~A-train-~A" line-code (subseq x #.(length "D-rescue-")))
(red:get x)))
(get-all (format nil "~A-rescue-*" line-code))))
(defun %find-rescuable-train (start rescuable bfs-depth)
(when (>= (decf bfs-depth) 0)
(loop
for neighbor in (gethash start *track-rescue-graph*)
with pos
when (setf pos (position neighbor rescuable :key #'cdr :test #'string=))
do (throw 'found (values bfs-depth pos))
unless (string= neighbor start)
do (%find-rescuable-train neighbor rescuable bfs-depth))))
(defun find-rescuable-train (start line-code max-depth)
(let ((rescuable (get-rescuable-trains line-code))
(real-x nil))
(multiple-value-bind (depth pos)
(catch 'found
(loop
;; this is a curse against computer science
;; I'm implementing BFS with DFS because I wrote DFS
;; and then I realised I made a mistake
;; so
for x from 1 upto max-depth
do (setf real-x x)
do (%find-rescuable-train start rescuable x)))
(when depth
(values (elt rescuable pos) real-x)))))
Loading…
Cancel
Save