diff options
Diffstat (limited to 'guix-data-service')
| -rw-r--r-- | guix-data-service/web/controller.scm | 255 | ||||
| -rw-r--r-- | guix-data-service/web/server.scm | 21 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 11 |
3 files changed, 163 insertions, 124 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index b344101..b6ecfa7 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -71,6 +71,7 @@ #:use-module (guix-data-service web repository controller) #:use-module (guix-data-service web package controller) #:export (%show-error-details + handle-static-assets controller)) (define cache-control-default-max-age @@ -513,16 +514,26 @@ (define* (controller request method-and-path-components mime-types body - secret-key-base) - (define (controller-thunk) + secret-key-base + startup-completed?) + (define (running-controller-thunk) (actual-controller request method-and-path-components mime-types body secret-key-base)) + (define (startup-controller-thunk) + (or + (base-controller request method-and-path-components) + (render-html + #:sxml (server-starting-up-page) + #:code 503))) + (call-with-error-handling - controller-thunk + (if startup-completed? + running-controller-thunk + startup-controller-thunk) #:on-error 'backtrace #:post-error (lambda args (render-html #:sxml (error-page @@ -531,51 +542,8 @@ #f)) #:code 500)))) -(define (actual-controller request - method-and-path-components - mime-types - body - secret-key-base) - (define path - (uri-path (request-uri request))) - - (define (delegate-to f) - (or (f request - method-and-path-components - mime-types - body) - (render-html - #:sxml (general-not-found - "Page not found" - "") - #:code 404))) - - (define (delegate-to-with-secret-key-base f) - (or (f request - method-and-path-components - mime-types - body - secret-key-base) - (render-html - #:sxml (general-not-found - "Page not found" - "") - #:code 404))) - +(define (base-controller request method-and-path-components) (match method-and-path-components - (('GET) - (render-html - #:sxml (index - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (map - (lambda (git-repository-details) - (cons - git-repository-details - (all-branches-with-most-recent-commit - conn (first git-repository-details)))) - (all-git-repositories conn)))))))) (('GET "assets" rest ...) (or (handle-static-assets (string-join rest "/") (request-headers request)) @@ -610,75 +578,124 @@ "README not found" "The README.html file does not exist") #:code 404)))) - (('GET "builds") - (delegate-to build-controller)) - (('GET "statistics") - (letpar& ((guix-revisions-count - (with-thread-postgresql-connection count-guix-revisions)) - (count-derivations - (with-thread-postgresql-connection count-derivations))) - - (render-html - #:sxml (view-statistics guix-revisions-count - count-derivations)))) - (('GET "metrics") - (render-metrics)) - (('GET "revision" args ...) - (delegate-to revision-controller)) - (('GET "repositories") - (delegate-to repository-controller)) - (('GET "repository" _ ...) - (delegate-to repository-controller)) - (('GET "package" _ ...) - (delegate-to package-controller)) - (('GET "gnu" "store" filename) - ;; These routes are a little special, as the extensions aren't used for - ;; content negotiation, so just use the path from the request - (let ((path (uri-path (request-uri request)))) - (if (string-suffix? ".drv" path) - (render-derivation (uri-decode path)) - (render-store-item (uri-decode path))))) - (('GET "gnu" "store" filename "formatted") - (if (string-suffix? ".drv" filename) - (render-formatted-derivation (string-append "/gnu/store/" filename)) - (render-html - #:sxml (general-not-found - "Not a derivation" - "The formatted display is only for derivations, where the filename ends in .drv") - #:code 404))) - (('GET "gnu" "store" filename "plain") - (if (string-suffix? ".drv" filename) - (let ((raw-drv - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-serialized-derivation-by-file-name - conn - (string-append "/gnu/store/" filename))))))) - (if raw-drv - (render-text raw-drv) - (not-found (request-uri request)))) - (not-found (request-uri request)))) - (('GET "gnu" "store" filename "narinfos") - (render-narinfos filename)) - (('GET "gnu" "store" filename "json") - (if (string-suffix? ".drv" filename) - (render-json-derivation (string-append "/gnu/store/" filename)) - (render-json-store-item (string-append "/gnu/store/" filename)))) - (('GET "build-servers") - (delegate-to-with-secret-key-base build-server-controller)) - (('GET "dumps" _ ...) - (delegate-to dumps-controller)) - (((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)) - (('GET "job" job-id) (delegate-to jobs-controller)) - (('GET _ ...) (delegate-to nar-controller)) - ((method path ...) - (render-html - #:sxml (general-not-found - "Page not found" - "") - #:code 404)))) + ((method path ...) #f))) + +(define (actual-controller request + method-and-path-components + mime-types + body + secret-key-base) + (define path + (uri-path (request-uri request))) + + (define (delegate-to f) + (or (f request + method-and-path-components + mime-types + body) + (render-html + #:sxml (general-not-found + "Page not found" + "") + #:code 404))) + + (define (delegate-to-with-secret-key-base f) + (or (f request + method-and-path-components + mime-types + body + secret-key-base) + (render-html + #:sxml (general-not-found + "Page not found" + "") + #:code 404))) + + (or + (base-controller request method-and-path-components) + (match method-and-path-components + (('GET) + (render-html + #:sxml (index + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (map + (lambda (git-repository-details) + (cons + git-repository-details + (all-branches-with-most-recent-commit + conn (first git-repository-details)))) + (all-git-repositories conn)))))))) + (('GET "builds") + (delegate-to build-controller)) + (('GET "statistics") + (letpar& ((guix-revisions-count + (with-thread-postgresql-connection count-guix-revisions)) + (count-derivations + (with-thread-postgresql-connection count-derivations))) + + (render-html + #:sxml (view-statistics guix-revisions-count + count-derivations)))) + (('GET "metrics") + (render-metrics)) + (('GET "revision" args ...) + (delegate-to revision-controller)) + (('GET "repositories") + (delegate-to repository-controller)) + (('GET "repository" _ ...) + (delegate-to repository-controller)) + (('GET "package" _ ...) + (delegate-to package-controller)) + (('GET "gnu" "store" filename) + ;; These routes are a little special, as the extensions aren't used for + ;; content negotiation, so just use the path from the request + (let ((path (uri-path (request-uri request)))) + (if (string-suffix? ".drv" path) + (render-derivation (uri-decode path)) + (render-store-item (uri-decode path))))) + (('GET "gnu" "store" filename "formatted") + (if (string-suffix? ".drv" filename) + (render-formatted-derivation (string-append "/gnu/store/" filename)) + (render-html + #:sxml (general-not-found + "Not a derivation" + "The formatted display is only for derivations, where the filename ends in .drv") + #:code 404))) + (('GET "gnu" "store" filename "plain") + (if (string-suffix? ".drv" filename) + (let ((raw-drv + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-serialized-derivation-by-file-name + conn + (string-append "/gnu/store/" filename))))))) + (if raw-drv + (render-text raw-drv) + (not-found (request-uri request)))) + (not-found (request-uri request)))) + (('GET "gnu" "store" filename "narinfos") + (render-narinfos filename)) + (('GET "gnu" "store" filename "json") + (if (string-suffix? ".drv" filename) + (render-json-derivation (string-append "/gnu/store/" filename)) + (render-json-store-item (string-append "/gnu/store/" filename)))) + (('GET "build-servers") + (delegate-to-with-secret-key-base build-server-controller)) + (('GET "dumps" _ ...) + (delegate-to dumps-controller)) + (((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)) + (('GET "job" job-id) (delegate-to jobs-controller)) + (('GET _ ...) (delegate-to nar-controller)) + ((method path ...) + (render-html + #:sxml (general-not-found + "Page not found" + "") + #:code 404))))) diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm index 05c0a58..599288c 100644 --- a/guix-data-service/web/server.scm +++ b/guix-data-service/web/server.scm @@ -24,12 +24,22 @@ #:use-module (web request) #:use-module (web uri) #:use-module (system repl error-handling) + #:use-module (ice-9 atomic) #:use-module (fibers web server) #:use-module (guix-data-service web controller) #:use-module (guix-data-service web util) #:export (start-guix-data-service-web-server)) -(define (handler request body controller secret-key-base) +(define (check-startup-completed startup-completed) + (if (atomic-box-ref startup-completed) + (begin + ;; Just in case this atomic-box-ref is expensive, only do it when + ;; necessary + (set! check-startup-completed (const #t)) + #t) + #f)) + +(define (handler request body controller secret-key-base startup-completed) (display (format #f "~a ~a\n" (request-method request) @@ -42,14 +52,17 @@ request-components) mime-types body - secret-key-base)))) + secret-key-base + (check-startup-completed startup-completed))))) -(define* (start-guix-data-service-web-server port host secret-key-base) +(define* (start-guix-data-service-web-server port host secret-key-base + startup-completed) (call-with-error-handling (lambda () (run-server (lambda (request body) (handler request body controller - secret-key-base)) + secret-key-base + startup-completed)) #:host host #:port port)) #:on-error 'backtrace diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 3f2c2ae..db1cdc4 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -50,7 +50,8 @@ view-narinfos view-store-item view-derivation-source-file - error-page)) + error-page + server-starting-up-page)) (define* (header) `(nav @@ -1004,3 +1005,11 @@ `((b ,key) (pre ,args)))) '()))))) + +(define* (server-starting-up-page) + (layout + #:body + `(,(header) + (div (@ (class "container")) + (h1 "Server is starting up") + (p "Database migrations are running, this can take some time."))))) |