Christopher Baines
af948de646
The equivalent_derivations table was an experiment that didn't work, so switch to using the derivations_by_output_details_set table. Also take the build server id as input, as this allows selecting derivations which have no known build for the relevant build server.
261 lines
8.5 KiB
Scheme
261 lines
8.5 KiB
Scheme
(define-module (guix-data-service builds)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 iconv)
|
|
#:use-module (json parser)
|
|
#:use-module (web response)
|
|
#:use-module (web client)
|
|
#:use-module (squee)
|
|
#:use-module (guix scripts substitute)
|
|
#:use-module (guix-data-service database)
|
|
#:use-module (guix-data-service builds)
|
|
#:use-module (guix-data-service model utils)
|
|
#:use-module (guix-data-service model build)
|
|
#:use-module (guix-data-service model build-server)
|
|
#:use-module (guix-data-service model build-status)
|
|
#:use-module (guix-data-service model nar)
|
|
#:export (query-build-servers))
|
|
|
|
(define (query-build-servers conn build-server-ids revision-commits)
|
|
(while #t
|
|
(let ((build-servers (select-build-servers conn)))
|
|
(for-each
|
|
(match-lambda
|
|
((id url lookup-all-derivations?)
|
|
(when (or (not build-servers)
|
|
(member id build-server-ids))
|
|
(when lookup-all-derivations?
|
|
(simple-format #t "\nQuerying ~A\n" url)
|
|
(query-build-server conn id url revision-commits)))))
|
|
build-servers))))
|
|
|
|
(define (query-build-server conn id url revision-commits)
|
|
(simple-format #t "\nFetching pending builds\n")
|
|
(process-pending-builds conn id url)
|
|
(simple-format #t "\nFetching unseen derivations\n")
|
|
(process-derivations conn id url revision-commits)
|
|
(simple-format #t "\nFetching narinfo files\n")
|
|
(fetch-narinfo-files conn id url revision-commits))
|
|
|
|
(define (insert-build-statuses-from-data conn build-server-id build-id data)
|
|
(define stop-statuses
|
|
(lset-difference string=?
|
|
build-status-strings
|
|
'("scheduled" "started")))
|
|
|
|
(let* ((status-string
|
|
(assq-ref build-statuses
|
|
(assoc-ref data "buildstatus")))
|
|
(finished?
|
|
(member status-string stop-statuses))
|
|
(existing-status-entries
|
|
(map second
|
|
(select-build-statuses-by-build-id conn
|
|
build-id
|
|
build-server-id)))
|
|
(timestamp
|
|
(assoc-ref data "timestamp"))
|
|
(starttime
|
|
(assoc-ref data "starttime"))
|
|
(stoptime
|
|
(assoc-ref data "stoptime")))
|
|
(map (match-lambda
|
|
((timestamp status)
|
|
(insert-build-status conn build-id timestamp status)))
|
|
(filter
|
|
list?
|
|
(list
|
|
(when (and
|
|
;; Cuirass returns the stoptime as the timestamp if the
|
|
;; build has finished, so only use the timestamp if the
|
|
;; build hasn't finished.
|
|
(not finished?)
|
|
(not (member "scheduled" existing-status-entries)))
|
|
(list timestamp "scheduled"))
|
|
(when (and (< 0 starttime)
|
|
(not (member "started" existing-status-entries)))
|
|
(list starttime "started"))
|
|
(when (and (< 0 stoptime)
|
|
(not (member status-string existing-status-entries)))
|
|
(list stoptime status-string)))))))
|
|
|
|
(define (process-pending-builds conn build-server-id url)
|
|
(for-each
|
|
(match-lambda
|
|
((build-id derivation-file-name)
|
|
(match (fetch-build url derivation-file-name)
|
|
(#f
|
|
(display ".")
|
|
#f)
|
|
(()
|
|
(display ".")
|
|
#f)
|
|
(data
|
|
(insert-build-statuses-from-data
|
|
conn
|
|
build-server-id
|
|
build-id
|
|
data)
|
|
(display "-")))
|
|
;; Try not to make to many requests at once
|
|
(usleep 200)))
|
|
(select-pending-builds conn build-server-id)))
|
|
|
|
(define (process-derivations conn build-server-id url revision-commits)
|
|
(define derivations
|
|
(select-derivations-with-no-known-build conn
|
|
build-server-id
|
|
revision-commits))
|
|
|
|
(simple-format (current-error-port) "Fetching ~A derivations\n"
|
|
(length derivations))
|
|
(for-each
|
|
(match-lambda
|
|
((derivation-id derivation-file-name)
|
|
(if
|
|
(and=> (fetch-build url derivation-file-name)
|
|
(lambda (data)
|
|
(let ((build-id
|
|
(ensure-build-exists conn
|
|
build-server-id
|
|
derivation-file-name)))
|
|
(insert-build-statuses-from-data
|
|
conn
|
|
build-server-id
|
|
build-id
|
|
data))
|
|
#t))
|
|
(display "-")
|
|
(display "."))
|
|
;; Try not to make to many requests at once
|
|
(usleep 200)))
|
|
derivations))
|
|
|
|
(define (json-string->scm* string)
|
|
(catch
|
|
'json-invalid
|
|
(lambda ()
|
|
(json-string->scm string))
|
|
(lambda args
|
|
(display args)
|
|
(newline)
|
|
(simple-format #t "\nerror parsing: ~A\n" string)
|
|
#f)))
|
|
|
|
(define (fetch-build url derivation-file-name)
|
|
(define build-url
|
|
(string-append url
|
|
"build"
|
|
(string-drop
|
|
derivation-file-name
|
|
(string-length "/gnu/store"))))
|
|
|
|
(let-values
|
|
(((response body)
|
|
(http-request build-url)))
|
|
|
|
(cond
|
|
((eq? (response-code response) 200)
|
|
(json-string->scm
|
|
(bytevector->string body "utf-8")))
|
|
(else
|
|
#f))))
|
|
|
|
(define (select-pending-builds conn build-server-id)
|
|
(define query
|
|
"
|
|
SELECT builds.id, derivations.file_name
|
|
FROM derivations
|
|
INNER JOIN builds
|
|
ON derivations.file_name = builds.derivation_file_name
|
|
LEFT JOIN (
|
|
SELECT DISTINCT ON (build_id) *
|
|
FROM build_status
|
|
ORDER BY build_id, timestamp DESC
|
|
) AS latest_build_status
|
|
ON builds.id = latest_build_status.build_id
|
|
WHERE builds.build_server_id = $1 AND
|
|
latest_build_status.status IN (
|
|
'scheduled', 'started'
|
|
)
|
|
ORDER BY latest_build_status.status DESC -- 'started' first
|
|
LIMIT 1000")
|
|
|
|
(map
|
|
(match-lambda
|
|
((build-id derivation-file-name)
|
|
(list (string->number build-id)
|
|
derivation-file-name)))
|
|
(exec-query conn query (list (number->string build-server-id)))))
|
|
|
|
(define (select-derivations-with-no-known-build conn
|
|
build-server-id
|
|
revision-commits)
|
|
(define query
|
|
;; Only select derivations that are in the package_derivations table, as
|
|
;; Cuirass doesn't build the intermediate derivations
|
|
(string-append
|
|
"
|
|
SELECT derivations.id, derivations.file_name
|
|
FROM derivations
|
|
INNER JOIN derivations_by_output_details_set
|
|
ON derivations.id = derivations_by_output_details_set.derivation_id
|
|
WHERE derivation_output_details_set_id NOT IN (
|
|
SELECT derivation_output_details_set_id
|
|
FROM builds
|
|
WHERE build_server_id = $1
|
|
) AND derivation_output_details_set_id IN (
|
|
SELECT derivation_output_details_set_id
|
|
FROM package_derivations
|
|
INNER JOIN derivations_by_output_details_set
|
|
ON package_derivations.derivation_id =
|
|
derivations_by_output_details_set.derivation_id"
|
|
(if (null? revision-commits)
|
|
"
|
|
WHERE"
|
|
(string-append
|
|
"
|
|
INNER JOIN guix_revision_package_derivations
|
|
ON package_derivations.id =
|
|
guix_revision_package_derivations.package_derivation_id
|
|
INNER JOIN guix_revisions
|
|
ON guix_revisions.id = guix_revision_package_derivations.revision_id
|
|
WHERE guix_revisions.commit IN ("
|
|
(string-join (map quote-string revision-commits) ",")
|
|
")
|
|
AND"))
|
|
"
|
|
-- TODO: Filter better on what systems and targets build servers use
|
|
package_derivations.system = 'x86_64-linux'
|
|
AND package_derivations.target = 'x86_64-linux'
|
|
)
|
|
ORDER BY derivation_output_details_set_id, derivations.id
|
|
LIMIT 15000"))
|
|
|
|
(exec-query conn query (list (number->string build-server-id))))
|
|
|
|
(define (fetch-narinfo-files conn build-server-id build-server-url revision-commits)
|
|
(define outputs
|
|
(select-outputs-for-successful-builds-without-known-nar-entries
|
|
conn
|
|
build-server-id
|
|
revision-commits))
|
|
|
|
(simple-format #t "Querying ~A outputs\n"
|
|
(length outputs))
|
|
|
|
(let ((narinfos
|
|
(lookup-narinfos (string-trim-right build-server-url #\/) outputs)))
|
|
|
|
(simple-format #t "Got ~A narinfo files\n"
|
|
(length narinfos))
|
|
|
|
(unless (eq? (length narinfos) 0)
|
|
(with-postgresql-transaction
|
|
conn
|
|
(lambda (conn)
|
|
(record-narinfo-details-and-return-ids
|
|
conn
|
|
build-server-id
|
|
narinfos))))))
|