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/controller.scm \
guix-data-service/web/compare/html.scm \ guix-data-service/web/compare/html.scm \
guix-data-service/web/controller.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/controller.scm \
guix-data-service/web/jobs/html.scm \ guix-data-service/web/jobs/html.scm \
guix-data-service/web/query-parameters.scm \ guix-data-service/web/query-parameters.scm \

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

@ -1,4 +1,5 @@
(define-module (guix-data-service builds) (define-module (guix-data-service builds)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 iconv) #:use-module (ice-9 iconv)
@ -28,21 +29,59 @@
(simple-format #t "\nFetching unseen derivations\n") (simple-format #t "\nFetching unseen derivations\n")
(process-derivations conn id url)) (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) (define (process-pending-builds conn build-server-id url)
(for-each (for-each
(match-lambda (match-lambda
((build-id internal-build-id derivation-id derivation-file-name) ((build-id derivation-file-name)
(match (fetch-build url build-id) (match (fetch-build url derivation-file-name)
(#f #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 ".") (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 ;; Try not to make to many requests at once
(usleep 200))) (usleep 200)))
(select-pending-builds conn build-server-id))) (select-pending-builds conn build-server-id)))
@ -51,48 +90,25 @@
(for-each (for-each
(match-lambda (match-lambda
((derivation-id derivation-file-name) ((derivation-id derivation-file-name)
(and=> (fetch-build-for-derivation url derivation-file-name) (if
(lambda (status) (and=> (fetch-build url derivation-file-name)
(let ((internal-build-id (lambda (data)
(let ((build-id
(ensure-build-exists conn (ensure-build-exists conn
build-server-id build-server-id
(assoc-ref status "id") derivation-file-name)))
derivation-id (insert-build-statuses-from-data
(assoc-ref status "timestamp")))) conn
build-server-id
(insert-build-status conn build-id
internal-build-id data))
(assoc-ref status "starttime") #t))
(assoc-ref status "stoptime") (display "-")
(assq-ref build-statuses (display "."))
(assoc-ref status "buildstatus"))))))
(display ".")
;; Try not to make to many requests at once ;; Try not to make to many requests at once
(usleep 200))) (usleep 200)))
(select-derivations-with-no-known-build conn))) (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) (define (json-string->scm* string)
(catch (catch
'json-invalid 'json-invalid
@ -104,78 +120,58 @@
(simple-format #t "\nerror parsing: ~A\n" string) (simple-format #t "\nerror parsing: ~A\n" string)
#f))) #f)))
(define (fetch-latest-builds-for-derivation base-url derivation-file-name) (define (fetch-build 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)
(let-values (let-values
(((response body) (((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 (cond
((eq? (response-code response) 200) ((eq? (response-code response) 200)
(json-string->scm (json-string->scm
(bytevector->string body "utf-8"))) (bytevector->string body "utf-8")))
(else (else
(simple-format #t "\nwarning: couldn't find build ~A on ~A\n"
id
url)
#f)))) #f))))
(define (select-pending-builds conn build-server-id) (define (select-pending-builds conn build-server-id)
(define query (define query
(string-append "
"SELECT builds.id, builds.internal_id, derivations.id, derivations.file_name " SELECT builds.id, derivations.file_name
"FROM derivations " FROM derivations
"INNER JOIN builds " INNER JOIN builds
"ON derivations.id = builds.derivation_id " ON derivations.file_name = builds.derivation_file_name
"INNER JOIN build_status " INNER JOIN build_status
"ON builds.internal_id = build_status.internal_build_id " ON builds.id = build_status.build_id
"WHERE builds.build_server_id = $1 AND " WHERE builds.build_server_id = $1 AND
"build_status.status IN (" build_status.status IN (
"'scheduled', 'started'" 'scheduled', 'started'
") " )
"LIMIT 1000")) 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 (select-derivations-with-no-known-build conn)
(define query (define query
(string-append ;; Only select derivations that are in the package_derivations table, as
"SELECT derivations.id, derivations.file_name " ;; Cuirass doesn't build the intermediate derivations
"FROM derivations " "
"WHERE derivations.id NOT IN (" SELECT derivations.id, derivations.file_name
"SELECT derivation_id FROM builds" FROM derivations
") " WHERE derivations.file_name NOT IN (
"LIMIT 15000")) SELECT derivation_file_name FROM builds
) AND derivations.id IN (
SELECT derivation_id FROM package_derivations
)
LIMIT 15000")
(exec-query conn query)) (exec-query conn query))

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

@ -12,10 +12,13 @@
secret-key-base secret-key-base
build-server-id build-server-id
token-seed))) token-seed)))
(string-filter
(base64-encode (base64-encode
(bytevector-hash (bytevector-hash
(string->utf8 source-string) (string->utf8 source-string)
(hash-algorithm sha1))))) (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 (compute-tokens-for-build-server conn secret-key-base build-server-id)
(define query (define query

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

@ -1,8 +1,12 @@
(define-module (guix-data-service model build-status) (define-module (guix-data-service model build-status)
#:use-module (ice-9 match)
#:use-module (squee) #:use-module (squee)
#:use-module (guix-data-service model utils)
#:export (build-statuses #:export (build-statuses
build-status-strings build-status-strings
insert-build-status)) select-build-statuses-by-build-id
insert-build-status
insert-build-statuses))
(define build-statuses (define build-statuses
'((-2 . "scheduled") '((-2 . "scheduled")
@ -16,25 +20,63 @@
(define build-status-strings (define build-status-strings
(map cdr build-statuses)) (map cdr build-statuses))
(define (insert-build-status conn internal-build-id (define (select-build-statuses-by-build-id conn
starttime stoptime status) build-id
(exec-query conn 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 (string-append
"INSERT INTO build_status " "
"(internal_build_id, starttime, stoptime, status) " INSERT INTO build_status (build_id, timestamp, status)
"VALUES " VALUES ("
"(" internal-build-id ", " (number->string build-id)
(if (eq? starttime 0)
"NULL"
(string-append "to_timestamp("
(number->string starttime)
")"))
", " ", "
(if (eq? stoptime 0)
"NULL"
(string-append "to_timestamp(" (string-append "to_timestamp("
(number->string stoptime) (number->string timestamp)
")")) ")")
", " ", "
"'" status "'" (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
"("
(number->string build-id)
","
(string-append "to_timestamp("
(number->string timestamp)
")")
","
(quote-string status)
")"))) ")")))
data
build-ids)
", ")))
(exec-query conn query '()))

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

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

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

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

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

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

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

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

@ -387,16 +387,19 @@
,@(map ,@(map
(match-lambda (match-lambda
((build-id build-server-url derivation-file-name ((build-id build-server-url derivation-file-name
status-fetched-at starttime stoptime status) timestamp status)
`(tr `(tr
(td (@ (class "text-center")) (td (@ (class "text-center"))
,(build-status-span status)) ,(build-status-span status))
(td (a (@ (href ,derivation-file-name)) (td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name))) ,(display-store-item-short derivation-file-name)))
(td ,starttime) (td ,timestamp)
(td ,stoptime)
(td (a (@ (href ,(simple-format (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))))) "View build on " ,build-server-url)))))
builds))))))))) builds)))))))))
@ -599,14 +602,17 @@
,(build-status-span ""))) ,(build-status-span "")))
(map (map
(match-lambda (match-lambda
((build-id build-server-url status-fetched-at ((build-server-url timestamp status)
starttime stoptime status)
`(div `(div
(@ (class "text-center")) (@ (class "text-center"))
(div ,(build-status-span status)) (div ,(build-status-span status))
(a (@ (style "display: inline-block; margin-top: 0.4em;") (a (@ (style "display: inline-block; margin-top: 0.4em;")
(href ,(simple-format (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)))) "View build on " ,build-server-url))))
builds))) builds)))
(div (div

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

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

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

@ -25,6 +25,7 @@
(use-modules (srfi srfi-1) (use-modules (srfi srfi-1)
(srfi srfi-37) (srfi srfi-37)
(ice-9 textual-ports)
(system repl server) (system repl server)
(guix-data-service config) (guix-data-service config)
(guix-data-service web server)) (guix-data-service web server))
@ -49,6 +50,12 @@
(alist-cons 'pid-file (alist-cons 'pid-file
arg arg
result))) 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 (option '("update-database") #f #f
(lambda (opt name _ result) (lambda (opt name _ result)
(alist-cons 'update-database #t result))) (alist-cons 'update-database #t result)))
@ -123,4 +130,5 @@
(assq-ref opts 'port)) (assq-ref opts 'port))
(start-guix-data-service-web-server (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 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 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 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;