guix-data-service/guix-data-service/utils.scm

;;; 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 ((guix build syscalls)
                #:select (set-thread-name))
  #: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

            fiberize

            chunk
            chunk!
            chunk-for-each!

            delete-duplicates/sort!

            get-guix-metrics-updater

            call-with-sigint

            spawn-port-monitoring-fiber

            make-queueing-channel))

(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* (fiberize proc #:key (parallelism 1))
  (let ((channel (make-channel)))
    (for-each
     (lambda _
       (spawn-fiber
        (lambda ()
          (while #t
            (let ((reply-channel args (car+cdr
                                       (get-message channel))))
              (put-message
               reply-channel
               (with-exception-handler
                   (lambda (exn)
                     (cons 'exception exn))
                 (lambda ()
                   (with-throw-handler #t
                     (lambda ()
                       (call-with-values
                           (lambda ()
                             (apply proc args))
                         (lambda vals
                           (cons 'result vals))))
                     (lambda _
                       (backtrace))))
                 #:unwind? #t)))))
        #:parallel? #t))
     (iota parallelism))

    (lambda args
      (let ((reply-channel (make-channel)))
        (put-message channel (cons reply-channel args))
        (match (get-message reply-channel)
          (('result . vals) (apply values vals))
          (('exception . exn) (raise-exception exn)))))))

(define (chunk lst max-length)
  (if (> (length lst)
         max-length)
      (call-with-values (lambda ()
                          (split-at lst max-length))
        (lambda (first-lst rest)
          (cons first-lst
                (chunk rest max-length))))
      (list lst)))

(define (chunk! lst max-length)
  (if (> (length lst)
         max-length)
      (call-with-values (lambda ()
                          (split-at! lst max-length))
        (lambda (first-lst rest)
          (cons first-lst
                (chunk! rest max-length))))
      (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 (eq? 1 (length (delete-duplicates list-lengths)))
      (error "lists not equal length"))

    (unless (eq? 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)))))

;; Copied from (fibers web server)
(define (call-with-sigint thunk cvar)
  (let ((handler #f))
    (dynamic-wind
      (lambda ()
        (set! handler
          (sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
      thunk
      (lambda ()
        (if handler
            ;; restore Scheme handler, SIG_IGN or SIG_DFL.
            (sigaction SIGINT (car handler) (cdr handler))
            ;; restore original C handler.
            (sigaction SIGINT #f))))))