cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rework the builds and build_status tables as well as related code

Browse source 
Allow for build status information to be submitted by POST request. This
required some changes to the builds and build_status tables, as for example,
the Cuirass build id may not be available, and the derivation may not be know
yet, so just record the derivation file name.
This commit is contained in:
Christopher Baines 2019-11-24 12:59:09 +00:00
parent 0ffd8caeeb
commit 5663235048
16 changed files with 510 additions and 229 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -94,6 +94,7 @@ SOURCES = \
guix-data-service/web/compare/controller.scm \
guix-data-service/web/compare/html.scm \
guix-data-service/web/controller.scm \
guix-data-service/web/build-server/controller.scm \
guix-data-service/web/jobs/controller.scm \
guix-data-service/web/jobs/html.scm \
guix-data-service/web/query-parameters.scm \

210
guix-data-service/builds.scm
View file

@ -1,4 +1,5 @@
(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)
@ -28,21 +29,59 @@
(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")))
(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
(unless (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 internal-build-id derivation-id derivation-file-name)
(match (fetch-build url build-id)
(#f #f)
(() #f)
(status
(insert-build-status conn
internal-build-id
(assoc-ref status "starttime")
(assoc-ref status "stoptime")
(assq-ref build-statuses
(assoc-ref status "buildstatus")))))
(display ".")
((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)))
@ -51,48 +90,25 @@
(for-each
(match-lambda
((derivation-id derivation-file-name)
(and=> (fetch-build-for-derivation url derivation-file-name)
(lambda (status)
(let ((internal-build-id
(ensure-build-exists conn
build-server-id
(assoc-ref status "id")
derivation-id
(assoc-ref status "timestamp"))))
(insert-build-status conn
internal-build-id
(assoc-ref status "starttime")
(assoc-ref status "stoptime")
(assq-ref build-statuses
(assoc-ref status "buildstatus"))))))
(display ".")
(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 (fetch-build-for-derivation url derivation-file-name)
(catch
#t
(lambda ()
(match (fetch-latest-builds-for-derivation url derivation-file-name)
((or #f #())
(match (fetch-queued-builds-for-derivation url derivation-file-name)
((or #f #())
(simple-format #t "\nwarning: couldn't find build for ~A on ~A\n"
derivation-file-name
url)
#f)
(#(status)
status)))
(#(status)
status)))
(lambda args
(simple-format #t "\nerror: couldn't fetch build for ~A on ~A\n"
derivation-file-name url)
(simple-format #t "error: ~A\n" args)
#f)))
(define (json-string->scm* string)
(catch
'json-invalid
@ -104,78 +120,58 @@
(simple-format #t "\nerror parsing: ~A\n" string)
#f)))
(define (fetch-latest-builds-for-derivation base-url derivation-file-name)
(define url
(string-append base-url
"api/latestbuilds?nr=1"
"&derivation=" derivation-file-name))
(let-values (((response body) (http-request url)))
(let ((code (response-code response)))
(cond
((eq? code 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else
(simple-format #t "\nerror: response code ~A: ~A\n" url code)
#f)))))
(define (fetch-queued-builds-for-derivation base-url derivation-file-name)
(define url
(string-append base-url
"api/queue?nr=1"
"&derivation=" derivation-file-name))
(let-values (((response body) (http-request url)))
(let ((code (response-code response)))
(cond
((eq? code 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else
(simple-format #t "\nerror: response code ~A: ~A\n" url code)
#f)))))
(define (fetch-build url id)
(define (fetch-build url derivation-file-name)
(let-values
(((response body)
(http-request (string-append url "build/" id))))
(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
(simple-format #t "\nwarning: couldn't find build ~A on ~A\n"
id
url)
#f))))
(define (select-pending-builds conn build-server-id)
(define query
(string-append
"SELECT builds.id, builds.internal_id, derivations.id, derivations.file_name "
"FROM derivations "
"INNER JOIN builds "
"ON derivations.id = builds.derivation_id "
"INNER JOIN build_status "
"ON builds.internal_id = build_status.internal_build_id "
"WHERE builds.build_server_id = $1 AND "
"build_status.status IN ("
"'scheduled', 'started'"
") "
"LIMIT 1000"))
"
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")
(exec-query conn query (list (number->string build-server-id))))
(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
(string-append
"SELECT derivations.id, derivations.file_name "
"FROM derivations "
"WHERE derivations.id NOT IN ("
"SELECT derivation_id FROM builds"
") "
"LIMIT 15000"))
;; 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))

11
guix-data-service/model/build-server-token-seed.scm
View file

@ -12,10 +12,13 @@
secret-key-base
build-server-id
token-seed)))
(base64-encode
(bytevector-hash
(string->utf8 source-string)
(hash-algorithm sha1)))))
(string-filter
(base64-encode
(bytevector-hash
(string->utf8 source-string)
(hash-algorithm sha1)))
;; Remove the + / and = to make handling the value easier
char-set:letter+digit)))
(define (compute-tokens-for-build-server conn secret-key-base build-server-id)
(define query

84
guix-data-service/model/build-status.scm
View file

@ -1,8 +1,12 @@
(define-module (guix-data-service model build-status)
#:use-module (ice-9 match)
#:use-module (squee)
#:use-module (guix-data-service model utils)
#:export (build-statuses
build-status-strings
insert-build-status))
select-build-statuses-by-build-id
insert-build-status
insert-build-statuses))
(define build-statuses
'((-2 . "scheduled")
@ -16,25 +20,63 @@
(define build-status-strings
(map cdr build-statuses))
(define (insert-build-status conn internal-build-id
starttime stoptime status)
(exec-query conn
(define (select-build-statuses-by-build-id conn
build-id
build-server-id)
(define query
"
SELECT timestamp, status
FROM build_status
INNER JOIN builds ON builds.id = build_status.build_id
WHERE builds.build_server_id = $1 AND
builds.id = $2")
(exec-query conn query (list (number->string build-server-id)
(number->string build-id))))
(define (insert-build-status conn build-id timestamp status)
(define query
(string-append
"
INSERT INTO build_status (build_id, timestamp, status)
VALUES ("
(number->string build-id)
", "
(string-append "to_timestamp("
(number->string timestamp)
")")
", "
(quote-string status)
")"))
(exec-query conn query '()))
(define (insert-build-statuses conn build-ids data)
(define query
(string-append
"
INSERT INTO build_status (build_id, timestamp, status)
VALUES "
(string-join
(map (match-lambda*
(((timestamp status) build-id)
(unless (member status build-status-strings)
(throw
'invalid-status
status))
(string-append
"INSERT INTO build_status "
"(internal_build_id, starttime, stoptime, status) "
"VALUES "
"(" internal-build-id ", "
(if (eq? starttime 0)
"NULL"
(string-append "to_timestamp("
(number->string starttime)
")"))
", "
(if (eq? stoptime 0)
"NULL"
(string-append "to_timestamp("
(number->string stoptime)
")"))
", "
"'" status "'"
"("
(number->string build-id)
","
(string-append "to_timestamp("
(number->string timestamp)
")")
","
(quote-string status)
")")))
data
build-ids)
", ")))
(exec-query conn query '()))

174
guix-data-service/model/build.scm
View file

@ -1,104 +1,122 @@
(define-module (guix-data-service model build)
#:use-module (ice-9 match)
#:use-module (squee)
#:use-module (guix-data-service model utils)
#:export (select-build-stats
select-builds-with-context
select-builds-with-context-by-derivation-id
select-build-by-build-server-and-id
select-builds-with-context-by-derivation-file-name
select-build-by-build-server-and-derivation-file-name
insert-builds
insert-build
ensure-build-exists))
(define (select-build-stats conn)
(define query
(string-append
"SELECT latest_build_status.status AS build_status, COUNT(*) "
"FROM derivations "
"FULL OUTER JOIN builds ON builds.derivation_id = derivations.id "
"FULL OUTER JOIN "
"(SELECT DISTINCT ON (internal_build_id) * FROM build_status "
"ORDER BY internal_build_id, status_fetched_at DESC"
") AS latest_build_status "
"ON builds.internal_id = latest_build_status.internal_build_id "
"GROUP BY (builds.id IS NULL), latest_build_status.status "
"ORDER BY build_status"))
"
SELECT latest_build_status.status AS build_status, COUNT(*)
FROM derivations
LEFT JOIN builds ON builds.derivation_file_name = derivations.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
GROUP BY latest_build_status.status
ORDER BY status")
(exec-query conn query))
(define (select-builds-with-context conn)
(define query
(string-append
"SELECT builds.id, build_servers.url, derivations.file_name, "
"latest_build_status.status_fetched_at, latest_build_status.starttime, "
"latest_build_status.stoptime, latest_build_status.status "
"FROM builds "
"INNER JOIN build_servers ON build_servers.id = builds.build_server_id "
"INNER JOIN derivations ON derivations.id = builds.derivation_id "
"INNER JOIN "
"(SELECT DISTINCT ON (internal_build_id) * "
"FROM build_status "
"ORDER BY internal_build_id, status_fetched_at DESC"
") AS latest_build_status "
"ON latest_build_status.internal_build_id = builds.internal_id "
"ORDER BY latest_build_status.status_fetched_at DESC "
"LIMIT 100"))
"
SELECT builds.id, build_servers.url, derivations.file_name,
latest_build_status.timestamp, latest_build_status.status
FROM builds
INNER JOIN build_servers ON build_servers.id = builds.build_server_id
INNER JOIN derivations ON derivations.file_name = builds.derivation_file_name
INNER JOIN
(
SELECT DISTINCT ON (build_id) *
FROM build_status
ORDER BY build_id, timestamp DESC
) AS latest_build_status
ON latest_build_status.build_id = builds.id
ORDER BY latest_build_status.timestamp DESC
LIMIT 100")
(exec-query conn query))
(define (select-builds-with-context-by-derivation-id conn derivation-id)
(define (select-builds-with-context-by-derivation-file-name
conn derivation-file-name)
(define query
(string-append
"SELECT builds.id, build_servers.url, "
"latest_build_status.status_fetched_at, latest_build_status.starttime, "
"latest_build_status.stoptime, latest_build_status.status "
"FROM builds "
"INNER JOIN build_servers ON build_servers.id = builds.build_server_id "
"INNER JOIN "
"(SELECT DISTINCT ON (internal_build_id) * "
"FROM build_status "
"ORDER BY internal_build_id, status_fetched_at DESC"
") AS latest_build_status "
"ON latest_build_status.internal_build_id = builds.internal_id "
"WHERE builds.derivation_id = $1 "
"ORDER BY latest_build_status.status_fetched_at DESC "))
"
SELECT build_servers.url,
latest_build_status.timestamp,
latest_build_status.status
FROM builds
INNER JOIN build_servers ON build_servers.id = builds.build_server_id
INNER JOIN
(
SELECT DISTINCT ON (build_id) *
FROM build_status
ORDER BY build_id, timestamp DESC
) AS latest_build_status
ON latest_build_status.build_id = builds.id
WHERE builds.derivation_file_name = $1
ORDER BY latest_build_status.timestamp DESC")
(exec-query conn query (list (number->string derivation-id))))
(exec-query conn query (list derivation-file-name)))
(define (select-build-by-build-server-and-id
conn build-server-id id)
(exec-query conn
(string-append
"SELECT internal_id, id, build_server_id, "
"derivation_id, timestamp "
"FROM builds "
"WHERE build_server_id = $1 AND id = $2")
(list build-server-id
(number->string id))))
(define (select-build-by-build-server-and-derivation-file-name
conn build-server-id derivation-file-name)
(define query
"
SELECT id, build_server_id, derivation_file_name
FROM builds
WHERE build_server_id = $1 AND derivation_file_name = $2")
(define (insert-build conn id build-server-id derivation-id timestamp)
(caar
(exec-query conn
(string-append
"INSERT INTO builds "
"(id, build_server_id, derivation_id, timestamp) "
"VALUES "
"($1, $2, $3, to_timestamp($4))"
"RETURNING "
"(internal_id)")
(list (number->string id)
build-server-id
derivation-id
(number->string timestamp)))))
(match (exec-query conn
query
(list (number->string build-server-id)
derivation-file-name))
((id) (string->number id))
(_
#f)))
(define (ensure-build-exists conn build-server-id id
derivation-id timestamp)
(let ((existing-build
(select-build-by-build-server-and-id
conn build-server-id id)))
(define (insert-builds conn build-server-id derivation-file-names)
(insert-missing-data-and-return-all-ids
conn
"builds"
'(build_server_id derivation_file_name)
(map (lambda (derivation-file-name)
(list build-server-id
derivation-file-name))
derivation-file-names)
#:delete-duplicates? #t))
(if (null? existing-build)
(define (insert-build conn build-server-id derivation-file-name)
(match (exec-query conn
"
INSERT INTO builds (build_server_id, derivation_file_name)
VALUES ($1, $2)
RETURNING (id)"
(list (number->string build-server-id)
derivation-file-name))
(((id))
(string->number id))))
(define (ensure-build-exists conn
build-server-id
derivation-file-name)
(let ((existing-build-id
(select-build-by-build-server-and-derivation-file-name
conn build-server-id derivation-file-name)))
(if existing-build-id
existing-build-id
(insert-build conn
id
build-server-id
derivation-id
timestamp)
(caar existing-build))))
derivation-file-name))))

145
guix-data-service/web/build-server/controller.scm Normal file
View file

@ -0,0 +1,145 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019 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 web build-server controller)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (json)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service jobs load-new-guix-revision)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service model build-status)
#:use-module (guix-data-service model build-server-token-seed)
#:use-module (guix-data-service web jobs html)
#:export (build-server-controller))
(define (handle-build-event-submission parsed-query-parameters
build-server-id-string
body
conn
secret-key-base)
(define build-server-id
(string->number build-server-id-string))
(define (handle-derivation-events items)
(unless (null? items)
(let ((build-ids
(insert-builds conn
build-server-id
(map (lambda (item)
(assoc-ref item "derivation"))
items))))
(insert-build-statuses
conn
build-ids
(map
(lambda (item-data)
(list (assoc-ref item-data "timestamp")
(assoc-ref item-data "event")))
items)))))
(define (process-items items)
(with-postgresql-transaction
conn
(lambda (conn)
(handle-derivation-events
(filter (lambda (item)
(let ((type (assoc-ref item "type")))
(if type
(string=? type "build")
(begin
(simple-format (current-error-port)
"warning: unknown type for event: ~A\n"
item)
#f))))
items)))))
(if (any-invalid-query-parameters? parsed-query-parameters)
(render-json
'((error . "no token provided"))
#:code 400)
(let ((provided-token (assq-ref parsed-query-parameters 'token))
(permitted-tokens (compute-tokens-for-build-server
conn
secret-key-base
build-server-id)))
(if (member provided-token
(map cdr permitted-tokens)
string=?)
(catch
'json-invalid
(lambda ()
(let ((body-string (utf8->string body)))
(let* ((body-json (json-string->scm body-string))
(items (and=> (assoc-ref body-json "items")
vector->list)))
(cond
((eq? items #f)
(render-json
'((error . "missing items key"))
#:code 400))
((null? items)
(render-json
'((error . "no items to process"))
#:code 400))
(else
(catch
#t
(lambda ()
(process-items items)
(no-content))
(lambda (key . args)
(simple-format (current-error-port)
"error processing events: ~A: ~A\n"
key
args)
(for-each (lambda (item)
(simple-format (current-error-port)
" ~A\n" item))
items)
(render-json
'((error . "could not process events"))
#:code 500))))))))
(lambda (key . args)
(render-json
'((error . "could not parse body as JSON"))
#:code 400)))
(render-json
'((error . "error"))
#:code 403)))))
(define (build-server-controller request
method-and-path-components
mime-types
body
conn
secret-key-base)
(match method-and-path-components
(('POST "build-server" build-server-id "build-events")
(let ((parsed-query-parameters
(parse-query-parameters
request
`((token ,identity #:required)))))
(handle-build-event-submission parsed-query-parameters
build-server-id
body
conn
secret-key-base)))
(_ #f)))

28
guix-data-service/web/controller.scm
View file

@ -21,10 +21,12 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 textual-ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (texinfo)
#:use-module (texinfo html)
@ -53,6 +55,7 @@
#:use-module (guix-data-service web revision controller)
#:use-module (guix-data-service web jobs controller)
#:use-module (guix-data-service web view html)
#:use-module (guix-data-service web build-server controller)
#:use-module (guix-data-service web compare controller)
#:use-module (guix-data-service web revision controller)
#:use-module (guix-data-service web repository controller)
@ -102,9 +105,9 @@
(derivation-outputs (select-derivation-outputs-by-derivation-id
conn
(first derivation)))
(builds (select-builds-with-context-by-derivation-id
(builds (select-builds-with-context-by-derivation-file-name
conn
(first derivation))))
(second derivation))))
(render-html
#:sxml (view-derivation derivation
derivation-inputs
@ -176,7 +179,9 @@
(static-asset-from-store-renderer)
render-static-asset))
(define (controller request method-and-path-components mime-types body)
(define (controller request method-and-path-components
mime-types body
secret-key-base)
(match method-and-path-components
(('GET "assets" rest ...)
(or (handle-static-assets (string-join rest "/")
@ -223,13 +228,15 @@
method-and-path-components
mime-types
body
conn))))))
conn
secret-key-base))))))
(define (controller-with-database-connection request
method-and-path-components
mime-types
body
conn)
conn
secret-key-base)
(define path
(uri-path (request-uri request)))
@ -241,6 +248,15 @@
conn)
(not-found (request-uri request))))
(define (delegate-to-with-secret-key-base f)
(or (f request
method-and-path-components
mime-types
body
conn
secret-key-base)
(not-found (request-uri request))))
(match method-and-path-components
(('GET)
(render-html
@ -276,6 +292,8 @@
(render-formatted-derivation conn
(string-append "/gnu/store/" filename))
(not-found (request-uri request))))
(((or 'GET 'POST) "build-server" _ ...)
(delegate-to-with-secret-key-base build-server-controller))
(('GET "compare" _ ...) (delegate-to compare-controller))
(('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
(('GET "jobs") (delegate-to jobs-controller))

5
guix-data-service/web/render.scm
View file

@ -39,6 +39,7 @@
not-found
unprocessable-entity
created
no-content
redirect))
(define file-mime-types
@ -167,6 +168,10 @@
(list (build-response #:code 201)
""))
(define (no-content)
(list (build-response #:code 204)
""))
(define (redirect path)
(let ((uri (build-uri 'http
#:host (%config 'host)

14
guix-data-service/web/server.scm
View file

@ -27,25 +27,27 @@
#:use-module (guix-data-service web util)
#:export (start-guix-data-service-web-server))
(define (run-controller controller request body)
(define (run-controller controller request body secret-key-base)
(let-values (((request-components mime-types)
(request->path-components-and-mime-type request)))
(controller request
(cons (request-method request)
request-components)
mime-types
body)))
body
secret-key-base)))
(define (handler request body controller)
(define (handler request body controller secret-key-base)
(display
(format #f "~a ~a\n"
(request-method request)
(uri-path (request-uri request))))
(apply values
(run-controller controller request body)))
(run-controller controller request body secret-key-base)))
(define (start-guix-data-service-web-server port host)
(define (start-guix-data-service-web-server port host secret-key-base)
(run-server (lambda (request body)
(handler request body controller))
(handler request body controller
secret-key-base))
#:host host
#:port port))

20
guix-data-service/web/view/html.scm
View file

@ -387,16 +387,19 @@
,@(map
(match-lambda
((build-id build-server-url derivation-file-name
status-fetched-at starttime stoptime status)
timestamp status)
`(tr
(td (@ (class "text-center"))
,(build-status-span status))
(td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name)))
(td ,starttime)
(td ,stoptime)
(td ,timestamp)
(td (a (@ (href ,(simple-format
#f "~Abuild/~A" build-server-url build-id)))
#f "~Abuild/~A"
build-server-url
(string-drop
derivation-file-name
(string-length "/gnu/store/")))))
"View build on " ,build-server-url)))))
builds)))))))))
@ -599,14 +602,17 @@
,(build-status-span "")))
(map
(match-lambda
((build-id build-server-url status-fetched-at
starttime stoptime status)
((build-server-url timestamp status)
`(div
(@ (class "text-center"))
(div ,(build-status-span status))
(a (@ (style "display: inline-block; margin-top: 0.4em;")
(href ,(simple-format
#f "~Abuild/~A" build-server-url build-id)))
#f "~Abuild/~A"
build-server-url
(string-drop
(second derivation)
(string-length "/gnu/store/")))))
"View build on " ,build-server-url))))
builds)))
(div

1
scripts/guix-data-service-query-build-servers.in
View file

@ -23,6 +23,7 @@
(use-modules (srfi srfi-1)
(srfi srfi-37)
(squee)
(guix-data-service database)
(guix-data-service builds))
(with-postgresql-connection "query-build-servers"

10
scripts/guix-data-service.in
View file

@ -25,6 +25,7 @@
(use-modules (srfi srfi-1)
(srfi srfi-37)
(ice-9 textual-ports)
(system repl server)
(guix-data-service config)
(guix-data-service web server))
@ -49,6 +50,12 @@
(alist-cons 'pid-file
arg
result)))
(option '("secret-key-base-file") #t #f
(lambda (opt name arg result)
(alist-cons 'secret-key-base
(string-trim-right
(call-with-input-file arg get-string-all))
result)))
(option '("update-database") #f #f
(lambda (opt name _ result)
(alist-cons 'update-database #t result)))
@ -123,4 +130,5 @@
(assq-ref opts 'port))
(start-guix-data-service-web-server (assq-ref opts 'port)
(assq-ref opts 'host)))
(assq-ref opts 'host)
(assq-ref opts 'secret-key-base)))

21
sqitch/deploy/rework_builds.sql Normal file
View file

@ -0,0 +1,21 @@
-- Deploy guix-data-service:rework_builds to pg
BEGIN;
DROP TABLE build_status;
DROP TABLE builds;
CREATE TABLE builds (
id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
build_server_id integer NOT NULL REFERENCES build_servers(id),
derivation_file_name varchar NOT NULL
);
CREATE TABLE build_status (
id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
build_id integer NOT NULL REFERENCES builds(id),
"timestamp" timestamp without time zone DEFAULT clock_timestamp() NOT NULL,
status guix_data_service.buildstatus NOT NULL
);
COMMIT;

7
sqitch/revert/rework_builds.sql Normal file
View file

@ -0,0 +1,7 @@
-- Revert guix-data-service:rework_builds from pg
BEGIN;
-- XXX Add DDLs here.
COMMIT;

1
sqitch/sqitch.plan
View file

@ -28,3 +28,4 @@ remove_guix_revision_duplicates 2019-10-05T08:00:14Z Christopher Baines <mail@cb
package_derivations_by_guix_revision_range 2019-11-09T19:09:48Z Christopher Baines <mail@cbaines.net> # Add package_derivations_by_guix_revision_range
channel_news_tables 2019-11-15T07:32:07Z Christopher Baines <mail@cbaines.net> # Add tables to store channel news
build_server_token_seeds 2019-11-23T09:26:48Z Christopher Baines <mail@cbaines.net> # Add build_server_token_seeds table
rework_builds 2019-11-23T20:41:20Z Christopher Baines <mail@cbaines.net> # Rework the build tables

7
sqitch/verify/rework_builds.sql Normal file
View file

@ -0,0 +1,7 @@
-- Verify guix-data-service:rework_builds on pg
BEGIN;
-- XXX Add verifications here.
ROLLBACK;