#!@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)
             (ice-9 match)
             (ice-9 textual-ports)
             (rnrs bytevectors)
             (json)
             (web uri)
             (web client))

(define %guix-data-service-host "data.guix.gnu.org")

(define %processed-commits-file "processed-revisions")

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

(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)))))

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

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

  (let-values (((response body) (http-get uri)))
    (json-string->scm (utf8->string body))))

(define (unseen-revisions)
  (let ((data (guix-data-service-request "/repository/1/branch/master.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 commit)
  (let ((port (open-file "processed-revisions" "a")))
    (simple-format port "~A\n" commit)
    (close-port port))

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

(define (channel-instance-derivations-for-commit commit system)
  (let ((data (guix-data-service-request
               (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 commit)
  (let ((data (guix-data-service-request
               (string-append "/revision/" commit "/package-derivations.json")
               '((system      . "x86_64-linux")
                 (target      . "none")
                 (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 derivation #:key (priority 0))
  (let ((exit-code
         (system* "guix-build-coordinator" "build"
                  ;; Currently submitting builds performs an allocation. Ideally this
                  ;; would just mark the plan as dirty to avoid repeatedly
                  ;; re-allocating builds. Until that point, pass this flag to skip
                  ;; allocating builds.
                  "--defer-allocation"
                  ;; For the use case of providing substitutes, just build each
                  ;; output once.
                  "--ignore-if-build-for-derivation-exists"
                  "--ignore-if-build-for-outputs-exists"
                  ;; The Guix Build Coordinator will automatically add builds for
                  ;; inputs if the required output isn't available, but to ensure
                  ;; this derivation, and all the related derivations have been built
                  ;; and the outputs stored, instruct the Guix Build Coordinator to
                  ;; add the builds upfront.
                  "--ensure-all-related-derivations-have-builds"
                  (simple-format #f "--priority=~A" priority)
                  derivation)))
    (unless (zero? exit-code)
      (error "build command failed"))))

(define (submit-builds-for-revision commit)
  (simple-format #t "looking at revision ~A\n" commit)
  (for-each (lambda (derivation)
              (submit-build derivation #:priority 1000))
            (channel-instance-derivations-for-commit commit "x86_64-linux"))

  (let ((unprocessed-package-derivations
         (filter (lambda (derivation)
                   (not (hash-ref processed-derivations-hash derivation)))
                 (package-derivations-for-commit commit))))

    (for-each submit-build unprocessed-package-derivations)
    (record-derivations-as-processed unprocessed-package-derivations)))

(define (main)
  (while #t
    (for-each (lambda (commit)
                (submit-builds-for-revision commit)
                (record-revision-as-processed commit))
              (unseen-revisions))

    (sleep 3600)))

(main)