mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Cuirass provides a timestamp field in build responses, and sometimes this means when the build was scheduled, but when the build is finished, it's the stoptime. So only use the timestamp when the build hasn't finished.
185 lines
5.7 KiB
Scheme
185 lines
5.7 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-data-service builds)
|
|
#:use-module (guix-data-service model build)
|
|
#:use-module (guix-data-service model build-server)
|
|
#:use-module (guix-data-service model build-status)
|
|
#:export (query-build-servers))
|
|
|
|
(define (query-build-servers conn)
|
|
(while #t
|
|
(let ((build-servers (select-build-servers conn)))
|
|
(for-each
|
|
(match-lambda
|
|
((id url lookup-all-derivations?)
|
|
(when lookup-all-derivations?
|
|
(query-build-server conn id url))))
|
|
build-servers))))
|
|
|
|
(define (query-build-server conn id url)
|
|
(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))
|
|
|
|
(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)
|
|
(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)))
|
|
(select-derivations-with-no-known-build conn)))
|
|
|
|
(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)
|
|
(let-values
|
|
(((response body)
|
|
(http-request (string-append
|
|
url
|
|
(string-append
|
|
"build"
|
|
(string-drop
|
|
derivation-file-name
|
|
(string-length "/gnu/store")))))))
|
|
|
|
(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
|
|
INNER JOIN build_status
|
|
ON builds.id = build_status.build_id
|
|
WHERE builds.build_server_id = $1 AND
|
|
build_status.status IN (
|
|
'scheduled', 'started'
|
|
)
|
|
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)
|
|
(define query
|
|
;; Only select derivations that are in the package_derivations table, as
|
|
;; Cuirass doesn't build the intermediate derivations
|
|
"
|
|
SELECT derivations.id, derivations.file_name
|
|
FROM derivations
|
|
WHERE derivations.file_name NOT IN (
|
|
SELECT derivation_file_name FROM builds
|
|
) AND derivations.id IN (
|
|
SELECT derivation_id FROM package_derivations
|
|
)
|
|
LIMIT 15000")
|
|
|
|
(exec-query conn query))
|