Browse Source

unfuck time

master
eta 2 months ago
parent
commit
48156c9f99
  1. 2
      deploy.txt
  2. 54
      trackernet.lisp
  3. 36
      wobsite.lisp

2
deploy.txt

@ -1,4 +1,4 @@
(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))
(load "trackernet.lisp")
(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)

54
trackernet.lisp

@ -342,6 +342,11 @@
(defparameter +months+ '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
(defparameter +europe-london-tz+
(progn
(local-time:reread-timezone-repository)
(local-time:find-timezone-by-location-name "Europe/London")))
(defun parse-trackernet-datetime (dt)
"this makes me sad"
(labels ((int-chomp ()
@ -372,8 +377,10 @@
(hour (int-chomp-tidy))
(min (int-chomp-tidy))
(sec (int-chomp-tidy)))
(encode-universal-time
sec min hour day month-num year))))
(local-time:timestamp-to-universal
(local-time:encode-timestamp
0 sec min hour day month-num year
:timezone +europe-london-tz+)))))
(defun fetch-trackernet-prediction (line-code station-code)
"Perform a Trackernet HTTP call to fetch the given station's predictions."
@ -538,7 +545,7 @@
(loop
for train in (get-trains pred)
do (redis-train universal-ts line-code code-station train))
(if (> (length (get-trains pred)) 0)
(if (red:exists (format nil "~A-trains-new" code-station))
;; swap out the new list of trains for the station
;; for the old list
(red:rename (format nil "~A-trains-new" code-station)
@ -589,13 +596,9 @@
(defun get-archivable-trains ()
"Returns a list of all trains that were last updated more than *TRAIN-ACTIVE-EXPIRY-SECS* ago."
(let* ((trains (get-all "?-train-*"))
(cutoff (- (get-universal-time) *train-active-expiry-secs*))
(dst-cutoff (- (+ 3600 (get-universal-time))
*train-active-expiry-secs*)))
(cutoff (- (get-universal-time) *train-active-expiry-secs*)))
(delete-if-not (lambda (train)
(or
(< (redis-last-score train) dst-cutoff)
(< (redis-last-score train) cutoff)))
(< (redis-last-score train) cutoff))
trains)))
(defun get-iso-8601-date ()
@ -639,29 +642,29 @@
:if-exists :append)
(conspack-encode-to-archive ar name data)))
(defun maybe-pigz-last-archive ()
"Runs `pigz` blocking-ly on yesterday's tar archive, if it exists."
(defun maybe-zstd-last-archive ()
"Runs `zstd` blocking-ly on yesterday's tar archive, if it exists."
(let ((filename (format nil "~A~A.tar"
*trackernet-trains-archival-dir*
(get-iso-8601-date-yesterday))))
(when (probe-file filename)
(format t "~&archiver: pigz'ing ~A, please wait~%"
(format t "~&archiver: zstd'ing ~A, please wait~%"
filename)
(let ((exit-code
(handler-case
(uiop:wait-process
(uiop:launch-program
`("pigz" ,filename)))
`("zstd" "--rm" ,filename)))
(error (e)
(format
*error-output*
"~&archiver: couldn't launch pigz: ~A~%"
"~&archiver: couldn't launch zstd: ~A~%"
e)))))
(if (and exit-code (zerop exit-code))
(format t "~&archiver: pigz'd last archive~%")
(format t "~&archiver: zstd'd last archive~%")
(format
*error-output*
"~&archiver: failed to pigz last archive: code ~A~%"
"~&archiver: failed to zstd last archive: code ~A~%"
exit-code))))))
(defparameter *rescue-max-dist* 8.0)
@ -678,7 +681,7 @@
(defun archive-trains-tar (keys)
"Archive trains from KEYS, a list of Redis train sorted set keys."
(maybe-pigz-last-archive)
(maybe-zstd-last-archive)
(archive:with-open-archive (tar
(format nil "~A~A.tar"
*trackernet-trains-archival-dir*
@ -751,15 +754,15 @@
(namestring (archive::entry-pathname entry)))
(t (archive::name entry))))
(defun make-pigz-decompressing-stream (in)
(defun make-zstd-decompressing-stream (in)
(uiop:process-info-output
(uiop:launch-program
"pigz -d"
"zstd -d"
:input in
:element-type '(unsigned-byte 8)
:output :stream)))
(defun unarchive-trains-tar (path func &key match (gzip-encoded (uiop:string-suffix-p path "gz")))
(defun unarchive-trains-tar (path func &key match (gzip-encoded (uiop:string-suffix-p path "zst")))
"Read trains from the archive at PATH, running FUNC on each decoded train object."
(with-open-file (in path
:direction :input
@ -772,7 +775,7 @@
(invoke-debugger c)))))
(archive:with-open-archive (tar
(if gzip-encoded
(make-pigz-decompressing-stream in)
(make-zstd-decompressing-stream in)
in)
:direction :input)
(archive:do-archive-entries (entry tar)
@ -1125,6 +1128,15 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(get-all (format nil "~A-active-*"
line-code)))
(defun line-track-descriptions (line-code)
"Returns an alist of all track codes and their textual descriptions for the given LINE-CODE."
(mapcar
(lambda (key)
(cons (subseq key #.(length "X-track-desc-Y"))
(red:get key)))
(get-all (format nil "~A-track-desc-*"
line-code))))
(defparameter *track-links-set* (make-hash-table
:test 'equal))

36
wobsite.lisp

@ -78,7 +78,7 @@
,@body))))
(hunchentoot:define-easy-handler (css :uri "/styles.css") ()
(hunchentoot:handle-static-file "./govuk.css"))
(hunchentoot:handle-static-file "~/common-lisp/intertube/govuk.css"))
(defun html-rgb-colour (r g b)
(format nil "#~2,'0x~2,'0x~2,'0x" r g b))
@ -136,10 +136,12 @@
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 display-trackernet-train (train &key code ts reporter)
(who:with-html-output-to-string (*standard-output* nil
@ -328,8 +330,30 @@
(local-time:now)
:format
'((:year 4) #\- (:month 2) #\- (:day 2) #\Space
(:hour 2) #\: (:min 2) #\: (:sec 2)))))
(:hour 2) #\: (:min 2) #\: (:sec 2))
:timezone
trackernet::+europe-london-tz+)))
".")
(: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, platform, or track code.")
(:input
:class "govuk-input"
:id "trackcode"
:name "trackcode"
:type "text"))
(:h2
:class "govuk-heading-l"
"Search by destination")
(:p
:class "govuk-body"
"Jump to: "

Loading…
Cancel
Save