You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
135 lines
4.4 KiB
135 lines
4.4 KiB
|
|
(define-once $stat-tree
|
|
(csv->sxml (open-input-file path-hr-cases)
|
|
#:record-sym (lambda x "rec")))
|
|
(define ($stat-tree-update)
|
|
(set! $stat-tree
|
|
(csv->sxml (open-input-file path-hr-cases)
|
|
#:record-sym (lambda x "rec")))
|
|
$stat-tree)
|
|
|
|
(define (log-stats-reset)
|
|
(sxml->xml $stat-tree (open-output-file
|
|
(string-append (yesterday-date-string)
|
|
"-stats.log")))
|
|
(for-each (lambda (sym)
|
|
(set-symbol-property! sym 'reports '()))
|
|
hr-syms))
|
|
|
|
;; Time Management
|
|
(define-once $base-time
|
|
(time-second
|
|
(date->time-utc
|
|
(string->date (get-string-all (open-input-file path-update-time))
|
|
"~Y~m~d~H~M"))))
|
|
|
|
(define ($base-time!)
|
|
(let ((new-time (strf->secs (get-string-all (open-input-file path-update-time))
|
|
"~Y~m~d~H~M")))
|
|
(begin (set! $base-time new-time)
|
|
($expiry-timestamp!)))
|
|
$base-time)
|
|
|
|
(define (updated?)
|
|
(let ((prev-base $base-time)
|
|
(new-time ($base-time!)))
|
|
(if (equal? prev-base new-time)
|
|
#f
|
|
#t)))
|
|
|
|
(define $expiry-timestamp
|
|
(let ((ct (time-second (current-time))))
|
|
(step-from $base-time sec/day ct)))
|
|
(define ($expiry-timestamp!)
|
|
(let ((ct (time-second (current-time))))
|
|
(set! $expiry-timestamp (step-from $base-time sec/day ct)))
|
|
$expiry-timestamp)
|
|
|
|
(define (next-timestamp)
|
|
(- ($expiry-timestamp!)
|
|
(time-second (current-time))))
|
|
|
|
;; Data Wrangling
|
|
(define-syntax rec
|
|
(syntax-rules ()
|
|
((rec ($prov $region $date $cases $c_cases))
|
|
(let* (($sym (symbol-fref (ssa> $prov "-" $region)))
|
|
($report-stack (if-some (symbol-property $sym 'reports))))
|
|
(unless (eq? $sym 'HR9999) ; special case, HR9999 has no meaningful data
|
|
(set-symbol-property! $sym 'reports (merge! $report-stack
|
|
'(($date . $cases))
|
|
(lambda (a b)
|
|
(time<? (car a)
|
|
(car b))))))))))
|
|
|
|
(define (process-stats! $tree)
|
|
(for-each
|
|
(lambda (x)
|
|
(eval x (interaction-environment)))
|
|
(pre-post-order
|
|
(cdr $tree)
|
|
`((province . ,(lambda (l x) x))
|
|
(health_region . ,(lambda (l x) x))
|
|
(date_report . ,(lambda (l x) (date->time-utc (string->date x "~d~m~Y"))))
|
|
(cases . ,(lambda (l x) (string->number x)))
|
|
(cumulative_cases . ,(lambda (l x) (string->number x)))
|
|
(*text* . ,(lambda (l x) x))
|
|
(*default* . ,(lambda x x))))))
|
|
|
|
(define (calculate-strings!)
|
|
(define (sum-first-n n $records)
|
|
(fold + 0 (map cdr (list-tail $records (- (length $records) n)))))
|
|
(for-each
|
|
(lambda (hr-sym)
|
|
(let* ((plist (symbol-pref hr-sym))
|
|
(json (scm->json-string
|
|
`((hr . ,(substring (ss< hr-sym) 2))
|
|
(population . ,(assq-ref plist 'population))
|
|
(hr-full . ,(assq-ref plist 'hr-full))
|
|
(hr-terse . ,(assq-ref plist 'terse))
|
|
(province . ,(assq-ref plist 'province))
|
|
(prov-terse . ,(assq-ref plist 'prov-code))
|
|
(last-7 . ,(sum-first-n 7 (assq-ref plist 'reports)))
|
|
(last-14 . ,(sum-first-n 14 (assq-ref plist 'reports)))))))
|
|
(set-symbol-property! hr-sym 'json-string json-esc)))
|
|
hr-syms))
|
|
|
|
;;Update Thread
|
|
(define %json-lock (make-mutex))
|
|
|
|
(define mcron-locked '())
|
|
|
|
(define (who-locked?)
|
|
(if (mutex-locked? %json-lock)
|
|
(if (eqv? (mutex-owner %json-lock) mcron-locked)
|
|
'mcron
|
|
'admin)
|
|
'()))
|
|
|
|
(define mcron:user (getpw (if-some-else (getlogin)
|
|
("covInd"))))
|
|
|
|
(define (job-loop)
|
|
(let loop ()
|
|
(git:fetch)
|
|
(if (updated?)
|
|
(begin (with-mutex %json-lock
|
|
(log-stats-reset)
|
|
(process-stats! ($stat-tree-update))
|
|
(calculate-strings!))
|
|
(sleep (next-timestamp)))
|
|
(begin (set! next-timestamp (+ next-timestamp (sec/mins 9)))
|
|
(sleep (sec/mins 9))))
|
|
(loop)))
|
|
|
|
(begin-thread (with-mutex %json-lock
|
|
(git:fetch)
|
|
(set! mcron-locked (mutex-owner %json-lock))
|
|
(process-stats! $stat-tree)
|
|
(calculate-strings!))
|
|
(sleep (next-timestamp))
|
|
(job-loop))
|
|
(sleep 1)
|
|
(while (mutex-locked? %json-lock)
|
|
(sleep 1))
|