From 5663235048b7341b378634d083eaae9f13580e07 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 24 Nov 2019 12:59:09 +0000 Subject: Rework the builds and build_status tables as well as related code 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. --- Makefile.am | 1 + guix-data-service/builds.scm | 212 ++++++++++----------- .../model/build-server-token-seed.scm | 11 +- guix-data-service/model/build-status.scm | 84 ++++++-- guix-data-service/model/build.scm | 174 +++++++++-------- guix-data-service/web/build-server/controller.scm | 145 ++++++++++++++ guix-data-service/web/controller.scm | 28 ++- guix-data-service/web/render.scm | 5 + guix-data-service/web/server.scm | 14 +- guix-data-service/web/view/html.scm | 20 +- scripts/guix-data-service-query-build-servers.in | 1 + scripts/guix-data-service.in | 10 +- sqitch/deploy/rework_builds.sql | 21 ++ sqitch/revert/rework_builds.sql | 7 + sqitch/sqitch.plan | 1 + sqitch/verify/rework_builds.sql | 7 + 16 files changed, 511 insertions(+), 230 deletions(-) create mode 100644 guix-data-service/web/build-server/controller.scm create mode 100644 sqitch/deploy/rework_builds.sql create mode 100644 sqitch/revert/rework_builds.sql create mode 100644 sqitch/verify/rework_builds.sql diff --git a/Makefile.am b/Makefile.am index e5dea6f..55083fd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 \ diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm index 8a92586..4ac42fb 100644 --- a/guix-data-service/builds.scm +++ b/guix-data-service/builds.scm @@ -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")) - - (exec-query conn query (list (number->string build-server-id)))) + " +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 - (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)) diff --git a/guix-data-service/model/build-server-token-seed.scm b/guix-data-service/model/build-server-token-seed.scm index 4a0c48d..454425b 100644 --- a/guix-data-service/model/build-server-token-seed.scm +++ b/guix-data-service/model/build-server-token-seed.scm @@ -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 diff --git a/guix-data-service/model/build-status.scm b/guix-data-service/model/build-status.scm index 26efde1..09f8623 100644 --- a/guix-data-service/model/build-status.scm +++ b/guix-data-service/model/build-status.scm @@ -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 '())) diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm index 74fe296..2e3385a 100644 --- a/guix-data-service/model/build.scm +++ b/guix-data-service/model/build.scm @@ -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") + + (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 + derivation-file-name)) + derivation-file-names) + #:delete-duplicates? #t)) -(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))))) +(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 id - derivation-id timestamp) - (let ((existing-build - (select-build-by-build-server-and-id - conn build-server-id 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 (null? existing-build) + (if existing-build-id + existing-build-id (insert-build conn - id build-server-id - derivation-id - timestamp) - (caar existing-build)))) + derivation-file-name)))) diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm new file mode 100644 index 0000000..3141043 --- /dev/null +++ b/guix-data-service/web/build-server/controller.scm @@ -0,0 +1,145 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019 Christopher Baines +;;; +;;; 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 +;;; . + +(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))) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 1e8d46a..5c21f97 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -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)) diff --git a/guix-data-service/web/render.scm b/guix-data-service/web/render.scm index eeaf99d..880035e 100644 --- a/guix-data-service/web/render.scm +++ b/guix-data-service/web/render.scm @@ -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) diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm index 695558c..4f81d4c 100644 --- a/guix-data-service/web/server.scm +++ b/guix-data-service/web/server.scm @@ -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)) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 1792440..c514f4f 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -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 diff --git a/scripts/guix-data-service-query-build-servers.in b/scripts/guix-data-service-query-build-servers.in index b0b3cd0..2662c89 100644 --- a/scripts/guix-data-service-query-build-servers.in +++ b/scripts/guix-data-service-query-build-servers.in @@ -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" diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index e8b35b5..d91b659 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -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))) diff --git a/sqitch/deploy/rework_builds.sql b/sqitch/deploy/rework_builds.sql new file mode 100644 index 0000000..3edfc2d --- /dev/null +++ b/sqitch/deploy/rework_builds.sql @@ -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; diff --git a/sqitch/revert/rework_builds.sql b/sqitch/revert/rework_builds.sql new file mode 100644 index 0000000..507808d --- /dev/null +++ b/sqitch/revert/rework_builds.sql @@ -0,0 +1,7 @@ +-- Revert guix-data-service:rework_builds from pg + +BEGIN; + +-- XXX Add DDLs here. + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index d3d9c7a..5990567 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -28,3 +28,4 @@ remove_guix_revision_duplicates 2019-10-05T08:00:14Z Christopher Baines # Add package_derivations_by_guix_revision_range channel_news_tables 2019-11-15T07:32:07Z Christopher Baines # Add tables to store channel news build_server_token_seeds 2019-11-23T09:26:48Z Christopher Baines # Add build_server_token_seeds table +rework_builds 2019-11-23T20:41:20Z Christopher Baines # Rework the build tables diff --git a/sqitch/verify/rework_builds.sql b/sqitch/verify/rework_builds.sql new file mode 100644 index 0000000..2dd6a15 --- /dev/null +++ b/sqitch/verify/rework_builds.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:rework_builds on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; -- cgit v1.2.3