path: root/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in

#!@GUILE@ --no-auto-compile
-*- scheme -*-
-*- geiser-scheme-implementation: guile -*-
!#
;;; Guix Build Coordinator
;;;
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of the guix-build-coordinator.
;;;
;;; guix-data-service is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; guix-data-service 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(use-modules (srfi srfi-1)
             (srfi srfi-11)
             (srfi srfi-37)
             (ice-9 match)
             (ice-9 textual-ports)
             (rnrs bytevectors)
             (json)
             (web uri)
             (web client)
             (guix-build-coordinator utils)
             (guix-build-coordinator client-communication))

;; This gets populated from a file on startup
(define processed-commits-hash
  (make-hash-table 1024))

(define processed-derivations-hash
  (make-hash-table 102400))

(define* (guix-data-service-request guix-data-service
                                    path
                                    #:optional (query-parameters '()))
  (define uri
    (string->uri (string-append
                  guix-data-service
                  path
                  (if (null? query-parameters)
                      ""
                      (string-append
                       "?"
                       (string-join
                        (map (match-lambda
                               ((key . value)
                                (simple-format #f "~A=~A" key value)))
                             query-parameters)
                        "&"))))))

  (retry-on-error
   (lambda ()
     (let-values (((response body) (http-get uri)))
       (json-string->scm (utf8->string body))))
   #:times 6
   #:delay 30))

(define (all-repository-ids guix-data-service)
  (let ((data (guix-data-service-request guix-data-service
                                         "/repositories.json")))
    (map (lambda (entry)
           (assoc-ref entry "id"))
         (vector->list
          (assoc-ref data "repositories")))))

(define (all-repository-branches guix-data-service repository-id)
  (let ((data (guix-data-service-request guix-data-service
                                         (string-append
                                          "/repository/"
                                          (number->string repository-id)
                                          ".json"))))
    (map (lambda (entry)
           (assoc-ref entry "name"))
         (vector->list
          (assoc-ref data "branches")))))

(define (unseen-revisions guix-data-service repository-id branch)
  (let ((data (guix-data-service-request guix-data-service
                                         (string-append
                                          "/repository/"
                                          (number->string repository-id)
                                          "/branch/"
                                          branch
                                          ".json"))))
    (filter-map (lambda (entry)
                  (let ((commit (assoc-ref entry "commit-hash")))
                    (and (not (hash-ref processed-commits-hash
                                        commit))
                         (assoc-ref entry "data_available")
                         commit)))
                (vector->list
                 (assoc-ref data "revisions")))))

(define (record-revision-as-processed processed-commits-file commit)
  (let ((port (open-file processed-commits-file "a")))
    (simple-format port "~A\n" commit)
    (close-port port))

  (hash-set! processed-commits-hash commit #t))

(define (channel-instance-derivations-for-commit guix-data-service
                                                 commit
                                                 system)
  (let ((data (guix-data-service-request
               guix-data-service
               (string-append "/revision/" commit "/channel-instances.json"))))
    (filter-map (lambda (entry)
                  (if (string=? system
                                (assoc-ref entry "system"))
                      (assoc-ref entry "derivation")
                      #f))
                (vector->list
                 (assoc-ref data "channel_instances")))))

(define* (package-derivations-for-commit guix-data-service
                                         commit
                                         #:key system target)
  (let ((data (guix-data-service-request
               guix-data-service
               (string-append "/revision/" commit "/package-derivations.json")
               `((system      . ,system)
                 (target      . ,target)
                 (field       . "(no-additional-fields)")
                 (all_results . "on")))))
    (map (lambda (entry)
           (assoc-ref entry "derivation"))
         (vector->list
          (assoc-ref data "derivations")))))

(define (record-derivations-as-processed derivations)
  (for-each (lambda (derivation)
              (hash-set! processed-derivations-hash
                         derivation
                         #t))
            derivations))

(define* (submit-build coordinator guix-data-service derivation #:key (priority 0))
  (retry-on-error
   (lambda ()
     (let ((response
            (send-submit-build-request
             coordinator
             derivation
             (list guix-data-service)
             #f
             priority
             #t
             #t
             #t
             '())))
       (let ((no-build-submitted-response
              (assoc-ref response "no-build-submitted")))
         (if no-build-submitted-response
             (simple-format #t "skipped: ~A\n"
                            no-build-submitted-response)
             (simple-format #t "build submitted as ~A\n"
                            (assoc-ref response "build-submitted"))))))
   ;; The TTL Guix uses for transient failures fetching substitutes is 10
   ;; minutes, so we need to retry for longer than that
   #:times 30
   #:delay 30))

(define (priority-for-derivation type system target)
  (cond
   ((eq? type 'channel-instance)
    (if (and (string=? system "x86_64-linux")
             (string=? target "none"))
        1000
        500))
   ((eq? type 'package)
    (if (and (string=? system "x86_64-linux")
             (string=? target "none"))
        500
        0))
   (else
    0)))

(define* (submit-builds-for-revision coordinator
                                     guix-data-service
                                     commit
                                     systems-and-targets
                                     #:key (submit-builds-for-channel-instances?
                                            #t))
  (simple-format #t "looking at revision ~A\n" commit)
  (for-each
   (match-lambda
     ((system . target)
      (when (string=? target "none")
        (when submit-builds-for-channel-instances?
          (for-each (lambda (derivation)
                      (submit-build coordinator
                                    guix-data-service
                                    derivation
                                    #:priority
                                    (priority-for-derivation 'channel-instance
                                                             system
                                                             target)))
                    (channel-instance-derivations-for-commit guix-data-service
                                                             commit
                                                             system))))

      (let ((unprocessed-package-derivations
             (filter (lambda (derivation)
                       (not (hash-ref processed-derivations-hash derivation)))
                     (package-derivations-for-commit guix-data-service
                                                     commit
                                                     #:system system
                                                     #:target target))))

        (for-each (lambda (derivation)
                    (submit-build coordinator
                                  guix-data-service
                                  derivation
                                  #:priority
                                  (priority-for-derivation 'package
                                                           system
                                                           target)))
                  unprocessed-package-derivations)
        (record-derivations-as-processed unprocessed-package-derivations))))
   systems-and-targets))

(define %options
  (list (option '("system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'systems-and-targets
                              `((,arg . "none")
                                ,@(or (assq-ref result 'systems-and-targets) '()))
                              (alist-delete 'systems-and-targets result))))
        (option '("system-and-target") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'systems-and-targets
                              (match (string-split arg #\=)
                                ((system target)
                                 `((,system . ,target)
                                   ,@(or (assq-ref result 'systems-and-targets) '()))))
                              (alist-delete 'systems-and-targets result))))
        (option '("fetch-channel-instance-derivations") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'fetch-channel-instance-derivations
                              (string=? arg "yes")
                              (alist-delete 'fetch-channel-instance-derivations
                                            result))))
        (option '("coordinator") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'coordinator
                              arg
                              (alist-delete 'coordinator result))))
        (option '("guix-data-service") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'guix-data-service
                              arg
                              (alist-delete 'guix-data-service result))))
        (option '("processed-commits-file") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'processed-commits-file
                              arg
                              (alist-delete 'processed-commits-file result))))))

(define %option-defaults
  '((coordinator                        . "http://127.0.0.1:8746")
    (guix-data-service                  . "https://data.guix.gnu.org")
    (processed-commits-file             . "processed-revisions")
    (fetch-channel-instance-derivations . #t)))

(define (parse-options options defaults args)
  (args-fold
   args options
   (lambda (opt name arg result)
     (error "unrecognized option" name))
   (lambda (arg result)
     (alist-cons
      'arguments
      (cons arg
            (or (assoc-ref result 'arguments)
                '()))
      (alist-delete 'arguments result)))
   defaults))

(define (main)
  (let* ((opts (parse-options %options
                              %option-defaults
                              (cdr (program-arguments))))
         (systems-and-targets
          (reverse
           (assq-ref opts 'systems-and-targets)))
         (guix-data-service
          (assq-ref opts 'guix-data-service))
         (processed-commits-file
          (assq-ref opts 'processed-commits-file)))

    (unless systems-and-targets
      (simple-format (current-error-port)
                     "error: you must specify at least one system to fetch builds for\n")
      (exit 1))

    (let ((arguments (or (assq-ref opts 'arguments) '())))
      (unless (null? arguments)
        (for-each (lambda (commit)
                    (submit-builds-for-revision (assq-ref opts 'coordinator)
                                                guix-data-service
                                                commit
                                                systems-and-targets))
                  arguments)
        (exit 0)))

    (when (file-exists? processed-commits-file)
      (call-with-input-file processed-commits-file
        (lambda (port)
          (let ((commits
                 (string-split (get-string-all port) #\newline)))
            (for-each (lambda (commit)
                        (unless (string-null? commit)
                          (simple-format #t "marking ~A as already processed\n"
                                         commit)
                          (hash-set! processed-commits-hash
                                     commit
                                     #t)))
                      commits)))))

    (while #t
      (for-each
       (lambda (repository-id)
         (for-each
          (lambda (branch)
            (for-each
             (lambda (commit)
               (submit-builds-for-revision
                (assq-ref opts 'coordinator)
                guix-data-service
                commit
                systems-and-targets
                #:submit-builds-for-channel-instances?
                (assq-ref opts 'fetch-channel-instance-derivations))
               (record-revision-as-processed processed-commits-file commit))
             (unseen-revisions guix-data-service
                               repository-id
                               branch)))
          (all-repository-branches guix-data-service
                                   repository-id)))
       (all-repository-ids guix-data-service))

      (simple-format #t "waiting before checking for new revisions...\n")
      (sleep 60))))

(main)