data-service/guix-data-service/substitutes.scm

;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019, 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 substitutes)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (fibers)
  #:use-module (fibers channels)
  #:use-module (guix substitutes)
  #:use-module (guix narinfo)
  #:use-module (guix-data-service utils)
  #:use-module (guix-data-service database)
  #:use-module (guix-data-service model build)
  #:use-module (guix-data-service model build-server)
  #:use-module (guix-data-service model git-branch)
  #:use-module (guix-data-service model git-repository)
  #:use-module (guix-data-service model nar)
  #:export (query-build-server-substitutes
            start-substitute-query-threads

            request-query-of-build-server-substitutes))

(define verbose-output?
  (make-parameter #f))

(define* (query-build-server-substitutes conn build-server-ids revision-commits
                                         outputs
                                         #:key verbose?)
  (parameterize
      ((verbose-output? verbose?))
    (let ((build-servers (select-build-servers conn)))
      (for-each
       (match-lambda
         ((id url lookup-all-derivations? lookup-builds?)
          (when (or (or (not build-servers)
                        (not build-server-ids))
                    (member id build-server-ids))
            (when lookup-all-derivations?
              (simple-format #t "\nQuerying ~A\n" url)
              (catch #t
                (lambda ()
                  (fetch-narinfo-files conn id url revision-commits
                                       #:specific-outputs
                                       outputs))
                (lambda (key . args)
                  (simple-format
                   (current-error-port)
                   "exception in query-build-server: ~A ~A\n"
                   key args)))))))
       build-servers))))

(define %narinfo-max-size
  (- (expt 2 (- (* 8 8) ;; 8 bytes
                1))
     1))

(define* (fetch-narinfo-files conn build-server-id build-server-url
                              revision-commits
                              #:key specific-outputs)
  (let loop ((last-id #f)
             (requests 0)
             (success-responses 0))
    (let ((outputs-chunk
           (or specific-outputs
               (select-outputs-without-known-nar-entries
                conn
                build-server-id
                revision-commits
                #:build-success-after
                (if (null? revision-commits)
                    (time-utc->date
                     (subtract-duration (current-time)
                                        (make-time time-duration 0 (* 60 5)))
                     0)                        ; tz-offset
                    #f)
                #:after-id last-id))))

      (unless (null? outputs-chunk)
        (let* ((narinfos
                (lookup-narinfos (string-trim-right build-server-url #\/)
                                 (map car outputs-chunk)))
               (narinfos-count
                (length narinfos))
               (total-requested
                (+ requests (length outputs-chunk)))
               (total-narinfos
                (+ success-responses narinfos-count)))

          (simple-format #t "Fetched ~A narinfos from ~A (total requested: ~A, total narinfos: ~A)\n"
                         (length narinfos)
                         build-server-url
                         total-requested
                         total-narinfos)

          (let ((filtered-narinfos
                 (filter-map
                  (lambda (narinfo)
                    (if (> (narinfo-size narinfo)
                           %narinfo-max-size)
                        (begin
                          (simple-format (current-error-port)
                                         "narinfo ~A has excessive size ~A\n"
                                         (narinfo-path narinfo)
                                         (narinfo-size narinfo))
                          #f)
                        narinfo))
                  narinfos)))

            (unless (null? filtered-narinfos)
              (with-postgresql-transaction
               conn
               (lambda (conn)
                 (record-narinfo-details-and-return-ids
                  conn
                  build-server-id
                  filtered-narinfos)))))

          (loop (second (last outputs-chunk))
                total-requested
                total-narinfos))))))

(define %substitute-query-channel #f)

(define (request-query-of-build-server-substitutes build-server-id
                                                   build-ids)
  (spawn-fiber
   (lambda ()
     (and=> %substitute-query-channel
            (lambda (channel)
              (put-message channel (cons build-server-id build-ids)))))))

(define (start-substitute-query-threads)
  (define channel
    (make-channel))

  (set! %substitute-query-channel channel)

  (call-with-new-thread
   (lambda ()
     (while #t
       (with-exception-handler
           (lambda (exn)
             (simple-format
              (current-error-port)
              "exception in request substitute query thread: ~A\n"
              exn))
         (lambda ()
           (with-throw-handler #t
             (lambda ()
               (with-postgresql-connection
                "request-substitute-query-thread"
                (lambda (conn)
                  (while #t
                    (match (get-message channel)
                      ((build-server-id . build-ids)

                       (let ((outputs
                              (delete-duplicates!
                               (append-map!
                                (lambda (build-id)
                                  (select-build-outputs conn build-id))
                                build-ids))))

                         (simple-format
                          (current-output-port)
                          "querying for ~A outputs from build server ~A\n"
                          (length outputs)
                          build-server-id)

                         (query-build-server-substitutes
                          conn
                          (list build-server-id)
                          #f
                          outputs))))))))
             (lambda _
               (backtrace))))
         #:unwind? #t))))

  (call-with-new-thread
   (lambda ()
     (while #t
       (with-exception-handler
           (lambda (exn)
             (simple-format (current-error-port)
                            "exception when querying substitutes: ~A\n"
                            exn))
         (lambda ()
           (with-postgresql-connection
            "substitute-query-thread"
            (lambda (conn)
              (for-each
               (match-lambda
                 ((git-repository-id rest ...)
                  (when (git-repository-query-substitutes? conn git-repository-id)
                    (for-each
                     (match-lambda
                       ((branch-name rest ...)
                        (and=> (latest-processed-commit-for-branch
                                conn
                                (number->string git-repository-id)
                                branch-name)
                               (lambda (commit)
                                 (query-build-server-substitutes
                                  conn
                                  #f ;; All build servers
                                  (list commit)
                                  #f)))))
                     (all-branches-with-most-recent-commit
                      conn
                      git-repository-id)))))
               (all-git-repositories conn))))

           (simple-format #t "finished checking substitutes, now sleeping\n")
           (sleep (* 60 30)))
         #:unwind? #t)))))