diff options
Diffstat (limited to 'guix-data-service/web')
| -rw-r--r-- | guix-data-service/web/build-server/controller.scm | 145 | ||||
| -rw-r--r-- | guix-data-service/web/controller.scm | 28 | ||||
| -rw-r--r-- | guix-data-service/web/render.scm | 5 | ||||
| -rw-r--r-- | guix-data-service/web/server.scm | 14 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 20 |
5 files changed, 194 insertions, 18 deletions
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 <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))) 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 |