280 lines
9 KiB
Scheme
280 lines
9 KiB
Scheme
;;; Guix Data Service -- Information about Guix over time
|
|
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU Affero General Public License
|
|
;;; as published by the Free Software Foundation, either version 3 of
|
|
;;; the License, or (at your option) any later version.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; Affero General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU Affero General Public
|
|
;;; License along with this program. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix-data-service utils)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (srfi srfi-71)
|
|
#:use-module (ice-9 q)
|
|
#:use-module (ice-9 ftw)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 atomic)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 threads)
|
|
#:use-module (ice-9 exceptions)
|
|
#:use-module (ice-9 ports internal)
|
|
#:use-module (ice-9 suspendable-ports)
|
|
#:use-module (lzlib)
|
|
#:use-module (fibers)
|
|
#:use-module (fibers channels)
|
|
#:use-module (fibers operations)
|
|
#:use-module (fibers timers)
|
|
#:use-module (fibers conditions)
|
|
#:use-module (fibers scheduler)
|
|
#:use-module (knots timeout)
|
|
#:use-module (prometheus)
|
|
#:export (call-with-time-logging
|
|
with-time-logging
|
|
prevent-inlining-for-tests
|
|
|
|
chunk
|
|
chunk!
|
|
chunk-for-each!
|
|
|
|
delete-duplicates/sort!
|
|
|
|
get-guix-metrics-updater
|
|
|
|
spawn-port-monitoring-fiber
|
|
|
|
make-queueing-channel
|
|
|
|
retry-on-error))
|
|
|
|
(define (call-with-time-logging action thunk)
|
|
(simple-format #t "debug: Starting ~A\n" action)
|
|
(let ((start-time (current-time)))
|
|
(let-values
|
|
((result (thunk)))
|
|
(let ((time-taken (- (current-time) start-time)))
|
|
(simple-format #t "debug: Finished ~A, took ~A seconds\n"
|
|
action time-taken))
|
|
(apply values result))))
|
|
|
|
(define-syntax-rule (with-time-logging action exp ...)
|
|
"Log under NAME the time taken to evaluate EXP."
|
|
(call-with-time-logging action (lambda () exp ...)))
|
|
|
|
(define-syntax-rule (prevent-inlining-for-tests var)
|
|
(set! var var))
|
|
|
|
(define (chunk lst max-length)
|
|
(let ((len (length lst)))
|
|
(cond
|
|
((= 0 len) '())
|
|
((> (length lst) max-length)
|
|
(call-with-values (lambda ()
|
|
(split-at lst max-length))
|
|
(lambda (first-lst rest)
|
|
(cons first-lst
|
|
(chunk rest max-length)))))
|
|
(else
|
|
(list lst)))))
|
|
|
|
(define (chunk! lst max-length)
|
|
(let ((len (length lst)))
|
|
(cond
|
|
((= 0 len) '())
|
|
((> (length lst) max-length)
|
|
(call-with-values (lambda ()
|
|
(split-at! lst max-length))
|
|
(lambda (first-lst rest)
|
|
(cons first-lst
|
|
(chunk! rest max-length)))))
|
|
(else
|
|
(list lst)))))
|
|
|
|
(define* (chunk-for-each! proc chunk-size #:rest lsts)
|
|
(define (do-one-iteration lsts)
|
|
(if (> (length (car lsts))
|
|
chunk-size)
|
|
(let ((chunks-and-rest
|
|
(map (lambda (lst)
|
|
(call-with-values (lambda ()
|
|
(split-at! lst chunk-size))
|
|
(lambda (first-lst rest)
|
|
(cons first-lst
|
|
rest))))
|
|
lsts)))
|
|
(apply proc
|
|
(map car chunks-and-rest))
|
|
(do-one-iteration
|
|
(map cdr chunks-and-rest)))
|
|
(apply proc lsts)))
|
|
|
|
(let ((list-lengths (map length lsts)))
|
|
(unless (= 1 (length (delete-duplicates list-lengths)))
|
|
(error "lists not equal length"))
|
|
|
|
(unless (= 0 (first list-lengths))
|
|
(do-one-iteration lsts)))
|
|
|
|
#t)
|
|
|
|
(define* (delete-duplicates/sort! unsorted-lst less #:optional (equal? equal?))
|
|
(if (null? unsorted-lst)
|
|
unsorted-lst
|
|
(let ((sorted-lst (sort! unsorted-lst less)))
|
|
|
|
(let loop ((lst (cdr sorted-lst))
|
|
(last-element (car sorted-lst))
|
|
(result (list (car sorted-lst))))
|
|
(if (null? lst)
|
|
result
|
|
(let ((current-element (car lst)))
|
|
(if (equal? current-element last-element)
|
|
(loop (cdr lst)
|
|
last-element
|
|
result)
|
|
(loop (cdr lst)
|
|
current-element
|
|
(cons current-element
|
|
result)))))))))
|
|
|
|
(define (get-guix-metrics-updater registry)
|
|
(define guix-db "/var/guix/db/db.sqlite")
|
|
(define guix-db-wal (string-append guix-db "-wal"))
|
|
|
|
(let ((guix-db-bytes-metric
|
|
(make-gauge-metric registry "guix_db_bytes"))
|
|
(guix-db-wal-bytes-metric
|
|
(make-gauge-metric registry "guix_db_wal_bytes")))
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda _
|
|
#f)
|
|
(lambda ()
|
|
(metric-set guix-db-bytes-metric (stat:size (stat guix-db)))
|
|
(metric-set guix-db-wal-bytes-metric
|
|
(if (file-exists? guix-db-wal)
|
|
(stat:size (stat guix-db-wal))
|
|
0)))
|
|
#:unwind? #t))))
|
|
|
|
(define (spawn-port-monitoring-fiber port error-condition)
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(while #t
|
|
(sleep 20)
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(simple-format (current-error-port)
|
|
"port monitoring fiber failed to connect to ~A: ~A\n"
|
|
port exn)
|
|
(signal-condition! error-condition))
|
|
(lambda ()
|
|
(with-port-timeouts
|
|
(lambda ()
|
|
(let ((sock (socket PF_INET SOCK_STREAM 0)))
|
|
(connect sock AF_INET INADDR_LOOPBACK port)
|
|
(close-port sock)))
|
|
#:timeout 20))
|
|
#:unwind? #t)))))
|
|
|
|
(define* (retry-on-error f #:key times delay (delay-seconds 0)
|
|
ignore no-retry error-hook
|
|
(sleep-impl sleep))
|
|
;; TODO Remove delay
|
|
(define real-delay-seconds
|
|
(or delay-seconds
|
|
delay))
|
|
|
|
(let loop ((attempt 1))
|
|
(match (with-exception-handler
|
|
(lambda (exn)
|
|
(if (cond
|
|
((list? ignore)
|
|
(any (lambda (test)
|
|
(test exn))
|
|
ignore))
|
|
((procedure? ignore)
|
|
(ignore exn))
|
|
(else #f))
|
|
`(#t . (,exn))
|
|
(begin
|
|
(when (cond
|
|
((list? no-retry)
|
|
(any (lambda (test)
|
|
(test exn))
|
|
no-retry))
|
|
((procedure? no-retry)
|
|
(no-retry exn))
|
|
(else #f))
|
|
(raise-exception exn))
|
|
|
|
(cons #f exn))))
|
|
(lambda ()
|
|
(call-with-values f
|
|
(lambda vals
|
|
(cons #t vals))))
|
|
#:unwind? #t)
|
|
((#t . return-values)
|
|
(when (> attempt 1)
|
|
(simple-format
|
|
(current-error-port)
|
|
"retry success: ~A\n on attempt ~A of ~A\n"
|
|
f
|
|
attempt
|
|
times))
|
|
(apply values return-values))
|
|
((#f . exn)
|
|
(if (>= attempt
|
|
(- times 1))
|
|
(begin
|
|
(simple-format
|
|
(current-error-port)
|
|
"error: ~A:\n ~A,\n attempt ~A of ~A, last retry in ~A\n"
|
|
f
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(print-exception
|
|
port
|
|
#f
|
|
'%exception
|
|
(list exn))))
|
|
attempt
|
|
times
|
|
real-delay-seconds)
|
|
(when error-hook
|
|
(error-hook attempt exn))
|
|
(sleep-impl real-delay-seconds)
|
|
(simple-format
|
|
(current-error-port)
|
|
"running last retry of ~A after ~A failed attempts\n"
|
|
f
|
|
attempt)
|
|
(f))
|
|
(begin
|
|
(simple-format
|
|
(current-error-port)
|
|
"error: ~A:\n ~A,\n attempt ~A of ~A, retrying in ~A\n"
|
|
f
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(print-exception
|
|
port
|
|
#f
|
|
'%exception
|
|
(list exn))))
|
|
attempt
|
|
times
|
|
real-delay-seconds)
|
|
(when error-hook
|
|
(error-hook attempt exn))
|
|
(sleep-impl real-delay-seconds)
|
|
(loop (+ 1 attempt))))))))
|